fenix
/
cpdf-source
mirror of https://github.com/johnwhitington/cpdf-source.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity
cpdf-source/xmlm.ml

1216 lines
42 KiB
OCaml
Raw Blame History

(*---------------------------------------------------------------------------
Copyright (c) 2007 Daniel C. Bünzli. All rights reserved.
Distributed under the ISC license, see terms at the end of the file.
%%NAME%% %%VERSION%%
---------------------------------------------------------------------------*)
module Std_string = String
module Std_buffer = Buffer
type std_string = string
type std_buffer = Buffer.t
module type String = sig
type t
val empty : t
val length : t -> int
val append : t -> t -> t
val lowercase : t -> t
val iter : (int -> unit) -> t -> unit
val of_string : std_string -> t
val to_utf_8 : ('a -> std_string -> 'a) -> 'a -> t -> 'a
val compare : t -> t -> int
end
module type Buffer = sig
type string
type t
exception Full
val create : int -> t
val add_uchar : t -> int -> unit
val clear : t -> unit
val contents : t -> string
val length : t -> int
end
module type S = sig
type string
type encoding = [
| `UTF_8 | `UTF_16 | `UTF_16BE | `UTF_16LE | `ISO_8859_1 | `US_ASCII ]
type dtd = string option
type name = string * string
type attribute = name * string
type tag = name * attribute list
type signal = [ `Dtd of dtd | `El_start of tag | `El_end | `Data of string ]
val ns_xml : string
val ns_xmlns : string
type pos = int * int
type error = [
| `Max_buffer_size
| `Unexpected_eoi
| `Malformed_char_stream
| `Unknown_encoding of string
| `Unknown_entity_ref of string
| `Unknown_ns_prefix of string
| `Illegal_char_ref of string
| `Illegal_char_seq of string
| `Expected_char_seqs of string list * string
| `Expected_root_element ]
exception Error of pos * error
val error_message : error -> string
type source = [
| `Channel of in_channel
| `String of int * std_string
| `Fun of (unit -> int) ]
type input
val make_input : ?enc:encoding option -> ?strip:bool ->
?ns:(string -> string option) ->
?entity: (string -> string option) -> source -> input
val input : input -> signal
val input_tree : el:(tag -> 'a list -> 'a) -> data:(string -> 'a) ->
input -> 'a
val input_doc_tree : el:(tag -> 'a list -> 'a) -> data:(string -> 'a) ->
input -> (dtd * 'a)
val peek : input -> signal
val eoi : input -> bool
val pos : input -> pos
type 'a frag = [ `El of tag * 'a list | `Data of string ]
type dest = [
| `Channel of out_channel | `Buffer of std_buffer | `Fun of (int -> unit) ]
type output
val make_output : ?decl:bool -> ?nl:bool -> ?indent:int option ->
?ns_prefix:(string -> string option) -> dest -> output
val output_depth : output -> int
val output : output -> signal -> unit
val output_tree : ('a -> 'a frag) -> output -> 'a -> unit
val output_doc_tree : ('a -> 'a frag) -> output -> (dtd * 'a) -> unit
end
(* Unicode character lexers *)
exception Malformed (* for character stream, internal only. *)
let utf8_len = [| (* Char byte length according to first UTF-8 byte. *)
1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1;
1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1;
1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1;
1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1;
1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1;
1; 1; 1; 1; 1; 1; 1; 1; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0;
0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0;
0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0;
0; 0; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2;
2; 2; 2; 2; 2; 2; 2; 2; 3; 3; 3; 3; 3; 3; 3; 3; 3; 3; 3; 3; 3; 3; 3; 3;
4; 4; 4; 4; 4; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0 |]
let uchar_utf8 i =
let b0 = i () in
begin match utf8_len.(b0) with
| 0 -> raise Malformed
| 1 -> b0
| 2 ->
let b1 = i () in
if b1 lsr 6 != 0b10 then raise Malformed else
((b0 land 0x1F) lsl 6) lor (b1 land 0x3F)
| 3 ->
let b1 = i () in
let b2 = i () in
if b2 lsr 6 != 0b10 then raise Malformed else
begin match b0 with
| 0xE0 -> if b1 < 0xA0 || 0xBF < b1 then raise Malformed else ()
| 0xED -> if b1 < 0x80 || 0x9F < b1 then raise Malformed else ()
| _ -> if b1 lsr 6 != 0b10 then raise Malformed else ()
end;
((b0 land 0x0F) lsl 12) lor ((b1 land 0x3F) lsl 6) lor (b2 land 0x3F)
| 4 ->
let b1 = i () in
let b2 = i () in
let b3 = i () in
if b3 lsr 6 != 0b10 || b2 lsr 6 != 0b10 then raise Malformed else
begin match b0 with
| 0xF0 -> if b1 < 0x90 || 0xBF < b1 then raise Malformed else ()
| 0xF4 -> if b1 < 0x80 || 0x8F < b1 then raise Malformed else ()
| _ -> if b1 lsr 6 != 0b10 then raise Malformed else ()
end;
((b0 land 0x07) lsl 18) lor ((b1 land 0x3F) lsl 12) lor
((b2 land 0x3F) lsl 6) lor (b3 land 0x3F)
| _ -> assert false
end
let int16_be i =
let b0 = i () in
let b1 = i () in
(b0 lsl 8) lor b1
let int16_le i =
let b0 = i () in
let b1 = i () in
(b1 lsl 8) lor b0
let uchar_utf16 int16 i =
let c0 = int16 i in
if c0 < 0xD800 || c0 > 0xDFFF then c0 else
if c0 > 0xDBFF then raise Malformed else
let c1 = int16 i in
(((c0 land 0x3FF) lsl 10) lor (c1 land 0x3FF)) + 0x10000
let uchar_utf16be = uchar_utf16 int16_be
let uchar_utf16le = uchar_utf16 int16_le
let uchar_byte i = i ()
let uchar_iso_8859_1 i = i ()
let uchar_ascii i = let b = i () in if b > 127 then raise Malformed else b
(* Functorized streaming XML IO *)
module Make (String : String) (Buffer : Buffer with type string = String.t) =
struct
type string = String.t
let str = String.of_string
let str_eq s s' = (compare s s') = 0
let str_empty s = (compare s String.empty) = 0
let cat = String.append
let str_of_char u =
let b = Buffer.create 4 in
Buffer.add_uchar b u;
Buffer.contents b
module Ht = Hashtbl.Make (struct type t = string
let equal = str_eq
let hash = Hashtbl.hash end)
let u_nl = 0x000A (* newline *)
let u_cr = 0x000D (* carriage return *)
let u_space = 0x0020 (* space *)
let u_quot = 0x0022 (* quote *)
let u_sharp = 0x0023 (* # *)
let u_amp = 0x0026 (* & *)
let u_apos = 0x0027 (* ' *)
let u_minus = 0x002D (* - *)
let u_slash = 0x002F (* / *)
let u_colon = 0x003A (* : *)
let u_scolon = 0x003B (* ; *)
let u_lt = 0x003C (* < *)
let u_eq = 0x003D (* = *)
let u_gt = 0x003E (* > *)
let u_qmark = 0x003F (* ? *)
let u_emark = 0x0021 (* ! *)
let u_lbrack = 0x005B (* [ *)
let u_rbrack = 0x005D (* ] *)
let u_x = 0x0078 (* x *)
let u_bom = 0xFEFF (* BOM *)
let u_9 = 0x0039 (* 9 *)
let u_F = 0x0046 (* F *)
let u_D = 0X0044 (* D *)
let s_cdata = str "CDATA["
let ns_xml = str "http://www.w3.org/XML/1998/namespace"
let ns_xmlns = str "http://www.w3.org/2000/xmlns/"
let n_xml = str "xml"
let n_xmlns = str "xmlns"
let n_space = str "space"
let n_version = str "version"
let n_encoding = str "encoding"
let n_standalone = str "standalone"
let v_yes = str "yes"
let v_no = str "no"
let v_preserve = str "preserve"
let v_default = str "default"
let v_version_1_0 = str "1.0"
let v_version_1_1 = str "1.1"
let v_utf_8 = str "utf-8"
let v_utf_16 = str "utf-16"
let v_utf_16be = str "utf-16be"
let v_utf_16le = str "utf-16le"
let v_iso_8859_1 = str "iso-8859-1"
let v_us_ascii = str "us-ascii"
let v_ascii = str "ascii"
let name_str (p,l) = if str_empty p then l else cat p (cat (str ":") l)
(* Basic types and values *)
type encoding = [
| `UTF_8 | `UTF_16 | `UTF_16BE | `UTF_16LE | `ISO_8859_1 | `US_ASCII ]
type dtd = string option
type name = string * string
type attribute = name * string
type tag = name * attribute list
type signal = [ `Dtd of dtd | `El_start of tag | `El_end | `Data of string ]
(* Input *)
type pos = int * int
type error = [
| `Max_buffer_size
| `Unexpected_eoi
| `Malformed_char_stream
| `Unknown_encoding of string
| `Unknown_entity_ref of string
| `Unknown_ns_prefix of string
| `Illegal_char_ref of string
| `Illegal_char_seq of string
| `Expected_char_seqs of string list * string
| `Expected_root_element ]
exception Error of pos * error
let error_message e =
let bracket l v r = cat (str l) (cat v (str r)) in
match e with
| `Expected_root_element -> str "expected root element"
| `Max_buffer_size -> str "maximal buffer size exceeded"
| `Unexpected_eoi -> str "unexpected end of input"
| `Malformed_char_stream -> str "malformed character stream"
| `Unknown_encoding e -> bracket "unknown encoding (" e ")"
| `Unknown_entity_ref e -> bracket "unknown entity reference (" e ")"
| `Unknown_ns_prefix e -> bracket "unknown namespace prefix (" e ")"
| `Illegal_char_ref s -> bracket "illegal character reference (#" s ")"
| `Illegal_char_seq s ->
bracket "character sequence illegal here (\"" s "\")"
| `Expected_char_seqs (exps, fnd) ->
let exps =
let exp acc v = cat acc (bracket "\"" v "\", ") in
List.fold_left exp String.empty exps
in
cat (str "expected one of these character sequence: ")
(cat exps (bracket "found \"" fnd "\""))
type limit = (* XML is odd to parse. *)
| Stag of name (* '<' qname *)
| Etag of name (* '</' qname whitespace* *)
| Pi of name (* '<?' qname *)
| Comment (* '<!--' *)
| Cdata (* '<![CDATA[' *)
| Dtd (* '<!' *)
| Text (* other character *)
| Eoi (* End of input *)
type source = [
| `Channel of in_channel
| `String of int * std_string
| `Fun of (unit -> int) ]
type input =
{ enc : encoding option; (* Expected encoding. *)
strip : bool; (* Whitespace stripping default behaviour. *)
fun_ns : string -> string option; (* Namespace callback. *)
fun_entity : string -> string option; (* Entity reference callback. *)
i : unit -> int; (* Byte level input. *)
mutable uchar : (unit -> int) -> int; (* Unicode character lexer. *)
mutable c : int; (* Character lookahead. *)
mutable cr : bool; (* True if last u was '\r'. *)
mutable line : int; (* Current line number. *)
mutable col : int; (* Current column number. *)
mutable limit : limit; (* Last parsed limit. *)
mutable peek : signal; (* Signal lookahead. *)
mutable stripping : bool; (* True if stripping whitespace. *)
mutable last_white : bool; (* True if last char was white. *)
mutable scopes : (name * string list * bool) list;
(* Stack of qualified el. name, bound prefixes and strip behaviour. *)
ns : string Ht.t; (* prefix -> uri bindings. *)
ident : Buffer.t; (* Buffer for names and entity refs. *)
data : Buffer.t; } (* Buffer for character and attribute data. *)
let err_input_tree = "input signal not `El_start or `Data"
let err_input_doc_tree = "input signal not `Dtd"
let err i e = raise (Error ((i.line, i.col), e))
let err_illegal_char i u = err i (`Illegal_char_seq (str_of_char u))
let err_expected_seqs i exps s = err i (`Expected_char_seqs (exps, s))
let err_expected_chars i exps =
err i (`Expected_char_seqs (List.map str_of_char exps, str_of_char i.c))
let u_eoi = max_int
let u_start_doc = u_eoi - 1
let u_end_doc = u_start_doc - 1
let signal_start_stream = `Data String.empty
let make_input ?(enc = None) ?(strip = false) ?(ns = fun _ -> None)
?(entity = fun _ -> None) src =
let i = match src with
| `Fun f -> f
| `Channel ic -> fun () -> input_byte ic
| `String (pos, s) ->
let len = Std_string.length s in
let pos = ref (pos - 1) in
fun () ->
incr pos;
if !pos = len then raise End_of_file else
Char.code (Std_string.get s !pos)
in
let bindings =
let h = Ht.create 15 in
Ht.add h String.empty String.empty;
Ht.add h n_xml ns_xml;
Ht.add h n_xmlns ns_xmlns;
h
in
{ enc = enc; strip = strip; fun_ns = ns; fun_entity = entity;
i = i; uchar = uchar_byte; c = u_start_doc; cr = false;
line = 1; col = 0; limit = Text; peek = signal_start_stream;
stripping = strip; last_white = true; scopes = []; ns = bindings;
ident = Buffer.create 64; data = Buffer.create 1024; }
(* Bracketed non-terminals in comments refer to XML 1.0 non terminals *)
let r : int -> int -> int -> bool = fun u a b -> a <= u && u <= b
let is_white = function 0x0020 | 0x0009 | 0x000D | 0x000A -> true | _ -> false
let is_char = function (* {Char} *)
| u when r u 0x0020 0xD7FF -> true
| 0x0009 | 0x000A | 0x000D -> true
| u when r u 0xE000 0xFFFD || r u 0x10000 0x10FFFF -> true
| _ -> false
let is_digit u = r u 0x0030 0x0039
let is_hex_digit u =
r u 0x0030 0x0039 || r u 0x0041 0x0046 || r u 0x0061 0x0066
let comm_range u = (* common to functions below *)
r u 0x00C0 0x00D6 || r u 0x00D8 0x00F6 || r u 0x00F8 0x02FF ||
r u 0x0370 0x037D || r u 0x037F 0x1FFF || r u 0x200C 0x200D ||
r u 0x2070 0x218F || r u 0x2C00 0x2FEF || r u 0x3001 0xD7FF ||
r u 0xF900 0xFDCF || r u 0xFDF0 0xFFFD || r u 0x10000 0xEFFFF
let is_name_start_char = function (* {NameStartChar} - ':' (XML 1.1) *)
| u when r u 0x0061 0x007A || r u 0x0041 0x005A -> true (* [a-z] | [A-Z] *)
| u when is_white u -> false
| 0x005F -> true (* '_' *)
| u when comm_range u -> true
| _ -> false
let is_name_char = function (* {NameChar} - ':' (XML 1.1) *)
| u when r u 0x0061 0x007A || r u 0x0041 0x005A -> true (* [a-z] | [A-Z] *)
| u when is_white u -> false
| u when r u 0x0030 0x0039 -> true (* [0-9] *)
| 0x005F | 0x002D | 0x002E | 0x00B7 -> true (* '_' '-' '.' *)
| u when comm_range u || r u 0x0300 0x036F || r u 0x203F 0x2040 -> true
| _ -> false
let rec nextc i =
if i.c = u_eoi then err i `Unexpected_eoi;
if i.c = u_nl then (i.line <- i.line + 1; i.col <- 1)
else i.col <- i.col + 1;
i.c <- i.uchar i.i;
if not (is_char i.c) then raise Malformed;
if i.cr && i.c = u_nl then i.c <- i.uchar i.i; (* cr nl business *)
if i.c = u_cr then (i.cr <- true; i.c <- u_nl) else i.cr <- false
let nextc_eof i = try nextc i with End_of_file -> i.c <- u_eoi
let skip_white i = while (is_white i.c) do nextc i done
let skip_white_eof i = while (is_white i.c) do nextc_eof i done
let accept i c = if i.c = c then nextc i else err_expected_chars i [ c ]
let clear_ident i = Buffer.clear i.ident
let clear_data i = Buffer.clear i.data
let addc_ident i c = Buffer.add_uchar i.ident c
let addc_data i c = Buffer.add_uchar i.data c
let addc_data_strip i c =
if is_white c then i.last_white <- true else
begin
if i.last_white && Buffer.length i.data <> 0 then addc_data i u_space;
i.last_white <- false;
addc_data i c
end
let expand_name i (prefix, local) =
let external_ prefix = match i.fun_ns prefix with
| None -> err i (`Unknown_ns_prefix prefix)
| Some uri -> uri
in
try
let uri = Ht.find i.ns prefix in
if not (str_empty uri) then (uri, local) else
if str_empty prefix then String.empty, local else
(external_ prefix), local (* unbound with xmlns:prefix="" *)
with Not_found -> external_ prefix, local
let find_encoding i = (* Encoding mess. *)
let reset uchar i = i.uchar <- uchar; i.col <- 0; nextc i in
match i.enc with
| None -> (* User doesn't know encoding. *)
begin match nextc i; i.c with
| 0xFE -> (* UTF-16BE BOM. *)
nextc i; if i.c <> 0xFF then err i `Malformed_char_stream;
reset uchar_utf16be i;
true
| 0xFF -> (* UTF-16LE BOM. *)
nextc i; if i.c <> 0xFE then err i `Malformed_char_stream;
reset uchar_utf16le i;
true
| 0xEF -> (* UTF-8 BOM. *)
nextc i; if i.c <> 0xBB then err i `Malformed_char_stream;
nextc i; if i.c <> 0xBF then err i `Malformed_char_stream;
reset uchar_utf8 i;
true
| 0x3C | _ -> (* UTF-8 or other, try declaration. *)
i.uchar <- uchar_utf8;
false
end
| Some e -> (* User knows encoding. *)
begin match e with
| `US_ASCII -> reset uchar_ascii i
| `ISO_8859_1 -> reset uchar_iso_8859_1 i
| `UTF_8 -> (* Skip BOM if present. *)
reset uchar_utf8 i; if i.c = u_bom then (i.col <- 0; nextc i)
| `UTF_16 -> (* Which UTF-16 ? look BOM. *)
let b0 = nextc i; i.c in
let b1 = nextc i; i.c in
begin match b0, b1 with
| 0xFE, 0xFF -> reset uchar_utf16be i
| 0xFF, 0xFE -> reset uchar_utf16le i
| _ -> err i `Malformed_char_stream;
end
| `UTF_16BE -> (* Skip BOM if present. *)
reset uchar_utf16be i; if i.c = u_bom then (i.col <- 0; nextc i)
| `UTF_16LE ->
reset uchar_utf16le i; if i.c = u_bom then (i.col <- 0; nextc i)
end;
true (* Ignore xml declaration. *)
let p_ncname i = (* {NCName} (Namespace 1.1) *)
clear_ident i;
if not (is_name_start_char i.c) then err_illegal_char i i.c else
begin
addc_ident i i.c; nextc i;
while is_name_char i.c do addc_ident i i.c; nextc i done;
Buffer.contents i.ident
end
let p_qname i = (* {QName} (Namespace 1.1) *)
let n = p_ncname i in
if i.c <> u_colon then (String.empty, n) else (nextc i; (n, p_ncname i))
let p_charref i = (* {CharRef}, '&' was eaten. *)
let c = ref 0 in
clear_ident i;
nextc i;
if i.c = u_scolon then err i (`Illegal_char_ref String.empty) else
begin
try
if i.c = u_x then
begin
addc_ident i i.c;
nextc i;
while (i.c <> u_scolon) do
addc_ident i i.c;
if not (is_hex_digit i.c) then raise Exit else
c := !c * 16 + (if i.c <= u_9 then i.c - 48 else
if i.c <= u_F then i.c - 55 else
i.c - 87);
nextc i;
done
end
else
while (i.c <> u_scolon) do
addc_ident i i.c;
if not (is_digit i.c) then raise Exit else
c := !c * 10 + (i.c - 48);
nextc i
done
with Exit ->
c := -1; while i.c <> u_scolon do addc_ident i i.c; nextc i done
end;
nextc i;
if is_char !c then (clear_ident i; addc_ident i !c; Buffer.contents i.ident)
else err i (`Illegal_char_ref (Buffer.contents i.ident))
let predefined_entities =
let h = Ht.create 5 in
let e k v = Ht.add h (str k) (str v) in
e "lt" "<"; e "gt" ">"; e "amp" "&"; e "apos" "'"; e "quot" "\"";
h
let p_entity_ref i = (* {EntityRef}, '&' was eaten. *)
let ent = p_ncname i in
accept i u_scolon;
try Ht.find predefined_entities ent with Not_found ->
match i.fun_entity ent with
| Some s -> s
| None -> err i (`Unknown_entity_ref ent)
let p_reference i = (* {Reference} *)
nextc i; if i.c = u_sharp then p_charref i else p_entity_ref i
let p_attr_value i = (* {S}? {AttValue} *)
skip_white i;
let delim =
if i.c = u_quot || i.c = u_apos then i.c else
err_expected_chars i [ u_quot; u_apos]
in
nextc i;
skip_white i;
clear_data i;
i.last_white <- true;
while (i.c <> delim) do
if i.c = u_lt then err_illegal_char i u_lt else
if i.c = u_amp then String.iter (addc_data_strip i) (p_reference i)
else (addc_data_strip i i.c; nextc i)
done;
nextc i;
Buffer.contents i.data
let p_attributes i = (* ({S} {Attribute})* {S}? *)
let rec aux i pre_acc acc =
if not (is_white i.c) then pre_acc, acc else
begin
skip_white i;
if i.c = u_slash || i.c = u_gt then pre_acc, acc else
begin
let (prefix, local) as n = p_qname i in
let v = skip_white i; accept i u_eq; p_attr_value i in
let att = n, v in
if str_empty prefix && str_eq local n_xmlns then
begin (* xmlns *)
Ht.add i.ns String.empty v;
aux i (String.empty :: pre_acc) (att :: acc)
end
else if str_eq prefix n_xmlns then
begin (* xmlns:local *)
Ht.add i.ns local v;
aux i (local :: pre_acc) (att :: acc)
end
else if str_eq prefix n_xml && str_eq local n_space then
begin (* xml:space *)
if str_eq v v_preserve then i.stripping <- false else
if str_eq v v_default then i.stripping <- i.strip else ();
aux i pre_acc (att :: acc)
end
else
aux i pre_acc (att :: acc)
end
end
in
aux i [] [] (* Returns a list of bound prefixes and attributes *)
let p_limit i = (* Parses a markup limit *)
i.limit <-
if i.c = u_eoi then Eoi else
if i.c <> u_lt then Text else
begin
nextc i;
if i.c = u_qmark then (nextc i; Pi (p_qname i)) else
if i.c = u_slash then
begin
nextc i;
let n = p_qname i in
skip_white i;
Etag n
end
else if i.c = u_emark then
begin
nextc i;
if i.c = u_minus then (nextc i; accept i u_minus; Comment) else
if i.c = u_D then Dtd else
if i.c = u_lbrack then
begin
nextc i;
clear_ident i;
for k = 1 to 6 do (addc_ident i i.c; nextc i) done;
let cdata = Buffer.contents i.ident in
if str_eq cdata s_cdata then Cdata else
err_expected_seqs i [ s_cdata ] cdata
end
else
err i (`Illegal_char_seq (cat (str "<!") (str_of_char i.c)))
end
else
Stag (p_qname i)
end
let rec skip_comment i = (* {Comment}, '<!--' was eaten *)
while (i.c <> u_minus) do nextc i done;
nextc i;
if i.c <> u_minus then skip_comment i else
begin
nextc i;
if i.c <> u_gt then err_expected_chars i [ u_gt ];
nextc_eof i
end
let rec skip_pi i = (* {PI}, '<?' qname was eaten *)
while (i.c <> u_qmark) do nextc i done;
nextc i;
if i.c <> u_gt then skip_pi i else nextc_eof i
let rec skip_misc i ~allow_xmlpi = match i.limit with (* {Misc}* *)
| Pi (p,l) when (str_empty p && str_eq n_xml (String.lowercase l)) ->
if allow_xmlpi then () else err i (`Illegal_char_seq l)
| Pi _ -> skip_pi i; p_limit i; skip_misc i ~allow_xmlpi
| Comment -> skip_comment i; p_limit i; skip_misc i ~allow_xmlpi
| Text when is_white i.c ->
skip_white_eof i; p_limit i; skip_misc i ~allow_xmlpi
| _ -> ()
let p_chardata addc i = (* {CharData}* ({Reference}{Chardata})* *)
while (i.c <> u_lt) do
if i.c = u_amp then String.iter (addc i) (p_reference i)
else if i.c = u_rbrack then
begin
addc i i.c;
nextc i;
if i.c = u_rbrack then begin
addc i i.c;
nextc i; (* detects ']'*']]>' *)
while (i.c = u_rbrack) do addc i i.c; nextc i done;
if i.c = u_gt then err i (`Illegal_char_seq (str "]]>"));
end
end
else
(addc i i.c; nextc i)
done
let rec p_cdata addc i = (* {CData} {CDEnd} *)
try while (true) do
if i.c = u_rbrack then begin
nextc i;
while i.c = u_rbrack do
nextc i;
if i.c = u_gt then (nextc i; raise Exit);
addc i u_rbrack
done;
addc i u_rbrack;
end;
addc i i.c;
nextc i;
done with Exit -> ()
let p_xml_decl i ~ignore_enc ~ignore_utf16 = (* {XMLDecl}? *)
let yes_no = [v_yes; v_no] in
let p_val i = skip_white i; accept i u_eq; skip_white i; p_attr_value i in
let p_val_exp i exp =
let v = p_val i in
if not (List.exists (str_eq v) exp) then err_expected_seqs i exp v
in
match i.limit with
| Pi (p, l) when (str_empty p && str_eq l n_xml) ->
let v = skip_white i; p_ncname i in
if not (str_eq v n_version) then err_expected_seqs i [ n_version ] v;
p_val_exp i [v_version_1_0; v_version_1_1];
skip_white i;
if i.c <> u_qmark then begin
let n = p_ncname i in
if str_eq n n_encoding then begin
let enc = String.lowercase (p_val i) in
if not ignore_enc then begin
if str_eq enc v_utf_8 then i.uchar <- uchar_utf8 else
if str_eq enc v_utf_16be then i.uchar <- uchar_utf16be else
if str_eq enc v_utf_16le then i.uchar <- uchar_utf16le else
if str_eq enc v_iso_8859_1 then i.uchar <- uchar_iso_8859_1 else
if str_eq enc v_us_ascii then i.uchar <- uchar_ascii else
if str_eq enc v_ascii then i.uchar <- uchar_ascii else
if str_eq enc v_utf_16 then
if ignore_utf16 then () else (err i `Malformed_char_stream)
(* A BOM should have been found. *)
else
err i (`Unknown_encoding enc)
end;
skip_white i;
if i.c <> u_qmark then begin
let n = p_ncname i in
if str_eq n n_standalone then p_val_exp i yes_no else
err_expected_seqs i [ n_standalone; str "?>" ] n
end
end
else if str_eq n n_standalone then
p_val_exp i yes_no
else
err_expected_seqs i [ n_encoding; n_standalone; str "?>" ] n
end;
skip_white i;
accept i u_qmark;
accept i u_gt;
p_limit i
| _ -> ()
let p_dtd_signal i =(* {Misc}* {doctypedecl} {Misc}* *)
skip_misc i ~allow_xmlpi:false;
if i.limit <> Dtd then `Dtd None else
begin
let buf = addc_data i in
let nest = ref 1 in
clear_data i;
buf u_lt; buf u_emark; (* add eaten "<!" *)
while (!nest > 0) do
if i.c = u_lt then
begin
nextc i;
if i.c <> u_emark then
(buf u_lt; incr nest)
else
begin
nextc i;
if i.c <> u_minus then (* Carefull with comments ! *)
(buf u_lt; buf u_emark; incr nest)
else
begin
nextc i;
if i.c <> u_minus then
(buf u_lt; buf u_emark; buf u_minus; incr nest)
else
(nextc i; skip_comment i)
end
end
end
else if i.c = u_quot || i.c = u_apos then
begin
let c = i.c in
buf c; nextc i;
while (i.c <> c) do (buf i.c; nextc i) done;
buf c; nextc i
end
else if i.c = u_gt then (buf u_gt; nextc i; decr nest)
else (buf i.c; nextc i)
done;
let dtd = Buffer.contents i.data in
p_limit i;
skip_misc i ~allow_xmlpi:false;
`Dtd (Some dtd);
end
let p_data i =
let rec bufferize addc i = match i.limit with
| Text -> p_chardata addc i; p_limit i; bufferize addc i
| Cdata -> p_cdata addc i; p_limit i; bufferize addc i
| (Stag _ | Etag _) -> ()
| Pi _ -> skip_pi i; p_limit i; bufferize addc i
| Comment -> skip_comment i; p_limit i; bufferize addc i
| Dtd -> err i (`Illegal_char_seq (str "<!D"))
| Eoi -> err i `Unexpected_eoi
in
clear_data i;
i.last_white <- true;
bufferize (if i.stripping then addc_data_strip else addc_data) i;
let d = Buffer.contents i.data in
d
let p_el_start_signal i n =
let expand_att (((prefix, local) as n, v) as att) =
if not (str_eq prefix String.empty) then expand_name i n, v else
if str_eq local n_xmlns then (ns_xmlns, n_xmlns), v else
att (* default namespaces do not influence attributes. *)
in
let strip = i.stripping in (* save it here, p_attributes may change it. *)
let prefixes, atts = p_attributes i in
i.scopes <- (n, prefixes, strip) :: i.scopes;
`El_start ((expand_name i n), List.rev_map expand_att atts)
let p_el_end_signal i n = match i.scopes with
| (n', prefixes, strip) :: scopes ->
if i.c <> u_gt then err_expected_chars i [ u_gt ];
if not (str_eq n n') then err_expected_seqs i [name_str n'] (name_str n);
i.scopes <- scopes;
i.stripping <- strip;
List.iter (Ht.remove i.ns) prefixes;
if scopes = [] then i.c <- u_end_doc else (nextc i; p_limit i);
`El_end
| _ -> assert false
let p_signal i =
if i.scopes = [] then
match i.limit with
| Stag n -> p_el_start_signal i n
| _ -> err i `Expected_root_element
else
let rec find i = match i.limit with
| Stag n -> p_el_start_signal i n
| Etag n -> p_el_end_signal i n
| Text | Cdata ->
let d = p_data i in
if str_empty d then find i else `Data d
| Pi _ -> skip_pi i; p_limit i; find i
| Comment -> skip_comment i; p_limit i; find i
| Dtd -> err i (`Illegal_char_seq (str "<!D"))
| Eoi -> err i `Unexpected_eoi
in
begin match i.peek with
| `El_start (n, _) -> (* finish to input start el. *)
skip_white i;
if i.c = u_gt then (accept i u_gt; p_limit i) else
if i.c = u_slash then
begin
let tag = match i.scopes with
| (tag, _, _) :: _ -> tag | _ -> assert false
in
(nextc i; i.limit <- Etag tag)
end
else
err_expected_chars i [ u_slash; u_gt ]
| _ -> ()
end;
find i
let eoi i =
try
if i.c = u_eoi then true else
if i.c <> u_start_doc then false else (* In a document. *)
if i.peek <> `El_end then (* Start of document sequence. *)
begin
let ignore_enc = find_encoding i in
p_limit i;
p_xml_decl i ~ignore_enc ~ignore_utf16:false;
i.peek <- p_dtd_signal i;
false
end
else (* Subsequent documents. *)
begin
nextc_eof i;
p_limit i;
if i.c = u_eoi then true else
begin
skip_misc i ~allow_xmlpi:true;
if i.c = u_eoi then true else
begin
p_xml_decl i ~ignore_enc:false ~ignore_utf16:true;
i.peek <- p_dtd_signal i;
false
end
end
end
with
| Buffer.Full -> err i `Max_buffer_size
| Malformed -> err i `Malformed_char_stream
| End_of_file -> err i `Unexpected_eoi
let peek i = if eoi i then err i `Unexpected_eoi else i.peek
let input i =
try
if i.c = u_end_doc then (i.c <- u_start_doc; i.peek) else
let s = peek i in
i.peek <- p_signal i;
s
with
| Buffer.Full -> err i `Max_buffer_size
| Malformed -> err i `Malformed_char_stream
| End_of_file -> err i `Unexpected_eoi
let input_tree ~el ~data i = match input i with
| `Data d -> data d
| `El_start tag ->
let rec aux i tags context = match input i with
| `El_start tag -> aux i (tag :: tags) ([] :: context)
| `El_end ->
begin match tags, context with
| tag :: tags', childs :: context' ->
let el = el tag (List.rev childs) in
begin match context' with
| parent :: context'' -> aux i tags' ((el :: parent) :: context'')
| [] -> el
end
| _ -> assert false
end
| `Data d ->
begin match context with
| childs :: context' -> aux i tags (((data d) :: childs) :: context')
| [] -> assert false
end
| `Dtd _ -> assert false
in
aux i (tag :: []) ([] :: [])
| _ -> invalid_arg err_input_tree
let input_doc_tree ~el ~data i = match input i with
| `Dtd d -> d, input_tree ~el ~data i
| _ -> invalid_arg err_input_doc_tree
let pos i = i.line, i.col
(* Output *)
type 'a frag = [ `El of tag * 'a list | `Data of string ]
type dest = [
| `Channel of out_channel | `Buffer of std_buffer | `Fun of (int -> unit) ]
type output =
{ decl : bool; (* True if the XML declaration should be output. *)
nl : bool; (* True if a newline is output at the end. *)
indent : int option; (* Optional indentation. *)
fun_prefix : string -> string option; (* Prefix callback. *)
prefixes : string Ht.t; (* uri -> prefix bindings. *)
outs : std_string -> int -> int -> unit; (* String output. *)
outc : char -> unit; (* character output. *)
mutable last_el_start : bool; (* True if last signal was `El_start *)
mutable scopes : (name * (string list)) list;
(* Qualified el. name and bound uris. *)
mutable depth : int; } (* Scope depth. *)
let err_prefix uri = "unbound namespace (" ^ uri ^ ")"
let err_dtd = "dtd signal not allowed here"
let err_el_start = "start signal not allowed here"
let err_el_end = "end signal without matching start signal"
let err_data = "data signal not allowed here"
let make_output ?(decl = true) ?(nl = false) ?(indent = None)
?(ns_prefix = fun _ ->None) d =
let outs, outc = match d with
| `Channel c -> (output c), (output_char c)
| `Buffer b -> (Std_buffer.add_substring b), (Std_buffer.add_char b)
| `Fun f ->
let os s p l =
for i = p to p + l - 1 do f (Char.code (Std_string.get s i)) done
in
let oc c = f (Char.code c) in
os, oc
in
let prefixes =
let h = Ht.create 10 in
Ht.add h String.empty String.empty;
Ht.add h ns_xml n_xml;
Ht.add h ns_xmlns n_xmlns;
h
in
{ decl = decl; outs = outs; outc = outc; nl = nl; indent = indent;
last_el_start = false; prefixes = prefixes; scopes = []; depth = -1;
fun_prefix = ns_prefix; }
let output_depth o = o.depth
let outs o s = o.outs s 0 (Std_string.length s)
let str_utf_8 s = String.to_utf_8 (fun _ s -> s) "" s
let out_utf_8 o s = ignore (String.to_utf_8 (fun o s -> outs o s; o) o s)
let prefix_name o (ns, local) =
try
if str_eq ns ns_xmlns && str_eq local n_xmlns then (String.empty, n_xmlns)
else (Ht.find o.prefixes ns, local)
with Not_found ->
match o.fun_prefix ns with
| None -> invalid_arg (err_prefix (str_utf_8 ns))
| Some prefix -> prefix, local
let bind_prefixes o atts =
let add acc ((ns, local), uri) =
if not (str_eq ns ns_xmlns) then acc else
begin
let prefix = if str_eq local n_xmlns then String.empty else local in
Ht.add o.prefixes uri prefix;
uri :: acc
end
in
List.fold_left add [] atts
let out_data o s =
let out () s =
let len = Std_string.length s in
let start = ref 0 in
let last = ref 0 in
let escape e =
o.outs s !start (!last - !start);
outs o e;
incr last;
start := !last
in
while (!last < len) do match Std_string.get s !last with
| '<' -> escape "&lt;" (* Escape markup delimiters. *)
| '>' -> escape "&gt;"
| '&' -> escape "&amp;"
(* | '\'' -> escape "&apos;" *) (* Not needed we use \x22 for attributes. *)
| '\x22' -> escape "&quot;"
| '\n' | '\t' | '\r' -> incr last
| c when c < ' ' -> escape "\xEF\xBF\xBD" (* illegal, subst. by U+FFFD *)
| _ -> incr last
done;
o.outs s !start (!last - !start)
in
String.to_utf_8 out () s
let out_qname o (p, l) =
if not (str_empty p) then (out_utf_8 o p; o.outc ':');
out_utf_8 o l
let out_attribute o (n, v) =
o.outc ' '; out_qname o (prefix_name o n); outs o "=\x22";
out_data o v;
o.outc '\x22'
let output o s =
let indent o = match o.indent with
| None -> ()
| Some c -> for i = 1 to (o.depth * c) do o.outc ' ' done
in
let unindent o = match o.indent with None -> () | Some _ -> o.outc '\n' in
if o.depth = -1 then
begin match s with
| `Dtd d ->
if o.decl then outs o "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n";
begin match d with
| Some dtd -> out_utf_8 o dtd; o.outc '\n'
| None -> ()
end;
o.depth <- 0
| `Data _ -> invalid_arg err_data
| `El_start _ -> invalid_arg err_el_start
| `El_end -> invalid_arg err_el_end
end
else
begin match s with
| `El_start (n, atts) ->
if o.last_el_start then (outs o ">"; unindent o);
indent o;
let uris = bind_prefixes o atts in
let qn = prefix_name o n in
o.outc '<'; out_qname o qn; List.iter (out_attribute o) atts;
o.scopes <- (qn, uris) :: o.scopes;
o.depth <- o.depth + 1;
o.last_el_start <- true
| `El_end ->
begin match o.scopes with
| (n, uris) :: scopes' ->
o.depth <- o.depth - 1;
if o.last_el_start then outs o "/>" else
begin
indent o;
outs o "</"; out_qname o n; o.outc '>';
end;
o.scopes <- scopes';
List.iter (Ht.remove o.prefixes) uris;
o.last_el_start <- false;
if o.depth = 0 then (if o.nl then o.outc '\n'; o.depth <- -1;)
else unindent o
| [] -> invalid_arg err_el_end
end
| `Data d ->
if o.last_el_start then (outs o ">"; unindent o);
indent o;
out_data o d;
unindent o;
o.last_el_start <- false
| `Dtd _ -> failwith err_dtd
end
let output_tree frag o v =
let rec aux o = function
| (v :: rest) :: context ->
begin match frag v with
| `El (tag, childs) ->
output o (`El_start tag);
aux o (childs :: rest :: context)
| (`Data d) as signal ->
output o signal;
aux o (rest :: context)
end
| [] :: [] -> ()
| [] :: context -> output o `El_end; aux o context
| [] -> assert false
in
aux o ([v] :: [])
let output_doc_tree frag o (dtd, v) =
output o (`Dtd dtd);
output_tree frag o v
end
(* Default streaming XML IO *)
module String = struct
type t = string
let empty = ""
let length = String.length
let append = ( ^ )
let lowercase = String.lowercase
let iter f s =
let len = Std_string.length s in
let pos = ref ~-1 in
let i () =
incr pos;
if !pos = len then raise Exit else
Char.code (Std_string.get s !pos)
in
try while true do f (uchar_utf8 i) done with Exit -> ()
let of_string s = s
let to_utf_8 f v x = f v x
let compare = String.compare
end
module Buffer = struct
type string = String.t
type t = Buffer.t
exception Full
let create = Buffer.create
let add_uchar b u =
try
(* UTF-8 encodes an uchar in the buffer, assumes u is valid code point. *)
let buf c = Buffer.add_char b (Char.chr c) in
if u <= 0x007F then
(buf u)
else if u <= 0x07FF then
(buf (0xC0 lor (u lsr 6));
buf (0x80 lor (u land 0x3F)))
else if u <= 0xFFFF then
(buf (0xE0 lor (u lsr 12));
buf (0x80 lor ((u lsr 6) land 0x3F));
buf (0x80 lor (u land 0x3F)))
else
(buf (0xF0 lor (u lsr 18));
buf (0x80 lor ((u lsr 12) land 0x3F));
buf (0x80 lor ((u lsr 6) land 0x3F));
buf (0x80 lor (u land 0x3F)))
with Failure _ -> raise Full
let clear b = Buffer.clear b
let contents = Buffer.contents
let length = Buffer.length
end
include Make(String) (Buffer)
(* Pretty printers *)
let pp = Format.fprintf
let rec pp_list ?(pp_sep = Format.pp_print_cut) pp_v ppf = function
| [] -> ()
| v :: vs ->
pp_v ppf v; if vs <> [] then (pp_sep ppf (); pp_list ~pp_sep pp_v ppf vs)
let pp_name ppf (p, l) = if p <> "" then pp ppf "%s:%s" p l else pp ppf "%s" l
let pp_attribute ppf (n, v) = pp ppf "@[<1>(%a,@,%S)@]" pp_name n v
let pp_tag ppf (name, atts) =
let pp_sep ppf () = pp ppf ";@ " in
pp ppf "@[<1>(%a,@,@[<1>[%a]@])@]"
pp_name name (pp_list ~pp_sep pp_attribute) atts
let pp_dtd ppf = function
| None -> pp ppf "None"
| Some dtd -> pp ppf "@[<1>(Some@ %S)@]" dtd
let pp_signal ppf = function
| `Data s -> pp ppf "@[`Data %S@]" s
| `El_end -> pp ppf "`El_end"
| `El_start tag -> pp ppf "@[`El_start %a@]" pp_tag tag
| `Dtd dtd -> pp ppf "@[`Dtd %a@]" pp_dtd dtd
(*----------------------------------------------------------------------------
Copyright (c) 2007 Daniel C. Bünzli
Permission to use, copy, modify, and/or distribute this software for any
purpose with or without fee is hereby granted, provided that the above
copyright notice and this permission notice appear in all copies.
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
---------------------------------------------------------------------------*)
Reference in New Issue View Git Blame Copy Permalink