diff options
| author |  ppedrot <ppedrot@85f007b7-540e-0410-9357-904b9bb8a0f7> | 2011-11-24 13:09:24 +0000 |
|---|---|---|
| committer | ppedrot <ppedrot@85f007b7-540e-0410-9357-904b9bb8a0f7> | 2011-11-24 13:09:24 +0000 |
| commit | 1f26b8591f3698699ee2143f5244a5d57243e283 (patch) | |
| tree | 978253d2f49e347d479b88c53542074ae9433986 /lib | |
| parent | 4484d5fc42c90bff13a1b9454a93b99b3fb94576 (diff) | |
Moving XML handling to lib directory
git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/coq/trunk@14723 85f007b7-540e-0410-9357-904b9bb8a0f7
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/lib.mllib | 3 | ||||
| -rw-r--r-- | lib/xml_lexer.mli | 44 | ||||
| -rw-r--r-- | lib/xml_lexer.mll | 304 | ||||
| -rw-r--r-- | lib/xml_parser.ml | 207 | ||||
| -rw-r--r-- | lib/xml_parser.mli | 115 | ||||
| -rw-r--r-- | lib/xml_utils.ml | 229 | ||||
| -rw-r--r-- | lib/xml_utils.mli | 93 |
7 files changed, 995 insertions, 0 deletions
diff --git a/lib/lib.mllib b/lib/lib.mllib index 635a35396..db79b5c24 100644 --- a/lib/lib.mllib +++ b/lib/lib.mllib @@ -1,3 +1,6 @@ +Xml_lexer +Xml_parser +Xml_utils Pp_control Pp Compat diff --git a/lib/xml_lexer.mli b/lib/xml_lexer.mli new file mode 100644 index 000000000..6edc414bf --- /dev/null +++ b/lib/xml_lexer.mli @@ -0,0 +1,44 @@ +(*
+ * Xml Light, an small Xml parser/printer with DTD support.
+ * Copyright (C) 2003 Nicolas Cannasse (ncannasse@motion-twin.com)
+ *
+ * This library 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; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library 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 library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+ *)
+
+type error =
+ | EUnterminatedComment
+ | EUnterminatedString
+ | EIdentExpected
+ | ECloseExpected
+ | ENodeExpected
+ | EAttributeNameExpected
+ | EAttributeValueExpected
+ | EUnterminatedEntity
+
+exception Error of error
+
+type token =
+ | Tag of string * (string * string) list * bool
+ | PCData of string
+ | Endtag of string
+ | Eof
+
+type pos = int * int * int * int
+
+val init : Lexing.lexbuf -> unit
+val close : Lexing.lexbuf -> unit
+val token : Lexing.lexbuf -> token
+val pos : Lexing.lexbuf -> pos
+val restore : pos -> unit
\ No newline at end of file diff --git a/lib/xml_lexer.mll b/lib/xml_lexer.mll new file mode 100644 index 000000000..3e5a47ed9 --- /dev/null +++ b/lib/xml_lexer.mll @@ -0,0 +1,304 @@ +{(*
+ * Xml Light, an small Xml parser/printer with DTD support.
+ * Copyright (C) 2003 Nicolas Cannasse (ncannasse@motion-twin.com)
+ *
+ * This library 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; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library 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 library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+ *)
+
+open Lexing
+
+type error =
+ | EUnterminatedComment
+ | EUnterminatedString
+ | EIdentExpected
+ | ECloseExpected
+ | ENodeExpected
+ | EAttributeNameExpected
+ | EAttributeValueExpected
+ | EUnterminatedEntity
+
+exception Error of error
+
+type pos = int * int * int * int
+
+type token =
+ | Tag of string * (string * string) list * bool
+ | PCData of string
+ | Endtag of string
+ | Eof
+
+let last_pos = ref 0
+and current_line = ref 0
+and current_line_start = ref 0
+
+let tmp = Buffer.create 200
+
+let idents = Hashtbl.create 0
+
+let _ = begin
+ Hashtbl.add idents "gt;" ">";
+ Hashtbl.add idents "lt;" "<";
+ Hashtbl.add idents "amp;" "&";
+ Hashtbl.add idents "apos;" "'";
+ Hashtbl.add idents "quot;" "\"";
+end
+
+let init lexbuf =
+ current_line := 1;
+ current_line_start := lexeme_start lexbuf;
+ last_pos := !current_line_start
+
+let close lexbuf =
+ Buffer.reset tmp
+
+let pos lexbuf =
+ !current_line , !current_line_start ,
+ !last_pos ,
+ lexeme_start lexbuf
+
+let restore (cl,cls,lp,_) =
+ current_line := cl;
+ current_line_start := cls;
+ last_pos := lp
+
+let newline lexbuf =
+ incr current_line;
+ last_pos := lexeme_end lexbuf;
+ current_line_start := !last_pos
+
+let error lexbuf e =
+ last_pos := lexeme_start lexbuf;
+ raise (Error e)
+
+}
+
+let newline = ['\n']
+let break = ['\r']
+let space = [' ' '\t']
+let identchar = ['A'-'Z' 'a'-'z' '_' '0'-'9' ':' '-']
+let entitychar = ['A'-'Z' 'a'-'z']
+let pcchar = [^ '\r' '\n' '<' '>' '&']
+
+rule token = parse
+ | newline
+ {
+ newline lexbuf;
+ token lexbuf
+ }
+ | (space | break) +
+ {
+ last_pos := lexeme_end lexbuf;
+ token lexbuf
+ }
+ | "<!--"
+ {
+ last_pos := lexeme_start lexbuf;
+ comment lexbuf;
+ token lexbuf
+ }
+ | "<?"
+ {
+ last_pos := lexeme_start lexbuf;
+ header lexbuf;
+ token lexbuf;
+ }
+ | '<' space* '/' space*
+ {
+ last_pos := lexeme_start lexbuf;
+ let tag = ident_name lexbuf in
+ ignore_spaces lexbuf;
+ close_tag lexbuf;
+ Endtag tag
+ }
+ | '<' space*
+ {
+ last_pos := lexeme_start lexbuf;
+ let tag = ident_name lexbuf in
+ ignore_spaces lexbuf;
+ let attribs, closed = attributes lexbuf in
+ Tag(tag, attribs, closed)
+ }
+ | "&#"
+ {
+ last_pos := lexeme_start lexbuf;
+ Buffer.reset tmp;
+ Buffer.add_string tmp (lexeme lexbuf);
+ PCData (pcdata lexbuf)
+ }
+ | '&'
+ {
+ last_pos := lexeme_start lexbuf;
+ Buffer.reset tmp;
+ Buffer.add_string tmp (entity lexbuf);
+ PCData (pcdata lexbuf)
+ }
+ | (space | newline | break)* pcchar+
+ {
+ last_pos := lexeme_start lexbuf;
+ Buffer.reset tmp;
+ Buffer.add_string tmp (lexeme lexbuf);
+ PCData (pcdata lexbuf)
+ }
+ | eof { Eof }
+ | _
+ { error lexbuf ENodeExpected }
+
+and ignore_spaces = parse
+ | newline
+ {
+ newline lexbuf;
+ ignore_spaces lexbuf
+ }
+ | (space | break) +
+ { ignore_spaces lexbuf }
+ | ""
+ { () }
+
+and comment = parse
+ | newline
+ {
+ newline lexbuf;
+ comment lexbuf
+ }
+ | "-->"
+ { () }
+ | eof
+ { raise (Error EUnterminatedComment) }
+ | _
+ { comment lexbuf }
+
+and header = parse
+ | newline
+ {
+ newline lexbuf;
+ header lexbuf
+ }
+ | "?>"
+ { () }
+ | eof
+ { error lexbuf ECloseExpected }
+ | _
+ { header lexbuf }
+
+and pcdata = parse
+ | pcchar+
+ {
+ Buffer.add_string tmp (lexeme lexbuf);
+ pcdata lexbuf
+ }
+ | "&#"
+ {
+ Buffer.add_string tmp (lexeme lexbuf);
+ pcdata lexbuf;
+ }
+ | '&'
+ {
+ Buffer.add_string tmp (entity lexbuf);
+ pcdata lexbuf
+ }
+ | ""
+ { Buffer.contents tmp }
+
+and entity = parse
+ | entitychar+ ';'
+ {
+ let ident = lexeme lexbuf in
+ try
+ Hashtbl.find idents (String.lowercase ident)
+ with
+ Not_found -> "&" ^ ident
+ }
+ | _ | eof
+ { raise (Error EUnterminatedEntity) }
+
+and ident_name = parse
+ | identchar+
+ { lexeme lexbuf }
+ | _ | eof
+ { error lexbuf EIdentExpected }
+
+and close_tag = parse
+ | '>'
+ { () }
+ | _ | eof
+ { error lexbuf ECloseExpected }
+
+and attributes = parse
+ | '>'
+ { [], false }
+ | "/>"
+ { [], true }
+ | "" (* do not read a char ! *)
+ {
+ let key = attribute lexbuf in
+ let data = attribute_data lexbuf in
+ ignore_spaces lexbuf;
+ let others, closed = attributes lexbuf in
+ (key, data) :: others, closed
+ }
+
+and attribute = parse
+ | identchar+
+ { lexeme lexbuf }
+ | _ | eof
+ { error lexbuf EAttributeNameExpected }
+
+and attribute_data = parse
+ | space* '=' space* '"'
+ {
+ Buffer.reset tmp;
+ last_pos := lexeme_end lexbuf;
+ dq_string lexbuf
+ }
+ | space* '=' space* '\''
+ {
+ Buffer.reset tmp;
+ last_pos := lexeme_end lexbuf;
+ q_string lexbuf
+ }
+ | _ | eof
+ { error lexbuf EAttributeValueExpected }
+
+and dq_string = parse
+ | '"'
+ { Buffer.contents tmp }
+ | '\\' [ '"' '\\' ]
+ {
+ Buffer.add_char tmp (lexeme_char lexbuf 1);
+ dq_string lexbuf
+ }
+ | eof
+ { raise (Error EUnterminatedString) }
+ | _
+ {
+ Buffer.add_char tmp (lexeme_char lexbuf 0);
+ dq_string lexbuf
+ }
+
+and q_string = parse
+ | '\''
+ { Buffer.contents tmp }
+ | '\\' [ '\'' '\\' ]
+ {
+ Buffer.add_char tmp (lexeme_char lexbuf 1);
+ q_string lexbuf
+ }
+ | eof
+ { raise (Error EUnterminatedString) }
+ | _
+ {
+ Buffer.add_char tmp (lexeme_char lexbuf 0);
+ q_string lexbuf
+ }
diff --git a/lib/xml_parser.ml b/lib/xml_parser.ml new file mode 100644 index 000000000..16d9922ae --- /dev/null +++ b/lib/xml_parser.ml @@ -0,0 +1,207 @@ +(*
+ * Xml Light, an small Xml parser/printer with DTD support.
+ * Copyright (C) 2003 Nicolas Cannasse (ncannasse@motion-twin.com)
+ * Copyright (C) 2003 Jacques Garrigue
+ *
+ * This library 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; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library 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 library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+ *)
+
+open Printf
+
+type xml =
+ | Element of (string * (string * string) list * xml list)
+ | PCData of string
+
+type error_pos = {
+ eline : int;
+ eline_start : int;
+ emin : int;
+ emax : int;
+}
+
+type error_msg =
+ | UnterminatedComment
+ | UnterminatedString
+ | UnterminatedEntity
+ | IdentExpected
+ | CloseExpected
+ | NodeExpected
+ | AttributeNameExpected
+ | AttributeValueExpected
+ | EndOfTagExpected of string
+ | EOFExpected
+
+type error = error_msg * error_pos
+
+exception Error of error
+
+exception File_not_found of string
+
+type t = {
+ mutable check_eof : bool;
+ mutable concat_pcdata : bool;
+}
+
+type source =
+ | SFile of string
+ | SChannel of in_channel
+ | SString of string
+ | SLexbuf of Lexing.lexbuf
+
+type state = {
+ source : Lexing.lexbuf;
+ stack : Xml_lexer.token Stack.t;
+ xparser : t;
+}
+
+exception Internal_error of error_msg
+exception NoMoreData
+
+let xml_error = ref (fun _ -> assert false)
+let file_not_found = ref (fun _ -> assert false)
+
+let _raises e f =
+ xml_error := e;
+ file_not_found := f
+
+let make () =
+ {
+ check_eof = true;
+ concat_pcdata = true;
+ }
+
+let check_eof p v = p.check_eof <- v
+let concat_pcdata p v = p.concat_pcdata <- v
+
+let pop s =
+ try
+ Stack.pop s.stack
+ with
+ Stack.Empty ->
+ Xml_lexer.token s.source
+
+let push t s =
+ Stack.push t s.stack
+
+let rec read_node s =
+ match pop s with
+ | Xml_lexer.PCData s -> PCData s
+ | Xml_lexer.Tag (tag, attr, true) -> Element (tag, attr, [])
+ | Xml_lexer.Tag (tag, attr, false) -> Element (tag, attr, read_elems ~tag s)
+ | t ->
+ push t s;
+ raise NoMoreData
+and
+ read_elems ?tag s =
+ let elems = ref [] in
+ (try
+ while true do
+ match s.xparser.concat_pcdata , read_node s , !elems with
+ | true , PCData c , (PCData c2) :: q ->
+ elems := PCData (sprintf "%s\n%s" c2 c) :: q
+ | _ , x , l ->
+ elems := x :: l
+ done
+ with
+ NoMoreData -> ());
+ match pop s with
+ | Xml_lexer.Endtag s when Some s = tag -> List.rev !elems
+ | Xml_lexer.Eof when tag = None -> List.rev !elems
+ | t ->
+ match tag with
+ | None -> raise (Internal_error EOFExpected)
+ | Some s -> raise (Internal_error (EndOfTagExpected s))
+
+let read_xml s = read_node s
+
+let convert = function
+ | Xml_lexer.EUnterminatedComment -> UnterminatedComment
+ | Xml_lexer.EUnterminatedString -> UnterminatedString
+ | Xml_lexer.EIdentExpected -> IdentExpected
+ | Xml_lexer.ECloseExpected -> CloseExpected
+ | Xml_lexer.ENodeExpected -> NodeExpected
+ | Xml_lexer.EAttributeNameExpected -> AttributeNameExpected
+ | Xml_lexer.EAttributeValueExpected -> AttributeValueExpected
+ | Xml_lexer.EUnterminatedEntity -> UnterminatedEntity
+
+let do_parse xparser source =
+ try
+ Xml_lexer.init source;
+ let s = { source = source; xparser = xparser; stack = Stack.create(); } in
+ let x = read_xml s in
+ if xparser.check_eof && pop s <> Xml_lexer.Eof then raise (Internal_error EOFExpected);
+ Xml_lexer.close source;
+ x
+ with
+ | NoMoreData ->
+ Xml_lexer.close source;
+ raise (!xml_error NodeExpected source)
+ | Internal_error e ->
+ Xml_lexer.close source;
+ raise (!xml_error e source)
+ | Xml_lexer.Error e ->
+ Xml_lexer.close source;
+ raise (!xml_error (convert e) source)
+
+let parse p = function
+ | SChannel ch -> do_parse p (Lexing.from_channel ch)
+ | SString str -> do_parse p (Lexing.from_string str)
+ | SLexbuf lex -> do_parse p lex
+ | SFile fname ->
+ let ch = (try open_in fname with Sys_error _ -> raise (!file_not_found fname)) in
+ try
+ let x = do_parse p (Lexing.from_channel ch) in
+ close_in ch;
+ x
+ with
+ e ->
+ close_in ch;
+ raise e
+
+
+let error_msg = function
+ | UnterminatedComment -> "Unterminated comment"
+ | UnterminatedString -> "Unterminated string"
+ | UnterminatedEntity -> "Unterminated entity"
+ | IdentExpected -> "Ident expected"
+ | CloseExpected -> "Element close expected"
+ | NodeExpected -> "Xml node expected"
+ | AttributeNameExpected -> "Attribute name expected"
+ | AttributeValueExpected -> "Attribute value expected"
+ | EndOfTagExpected tag -> sprintf "End of tag expected : '%s'" tag
+ | EOFExpected -> "End of file expected"
+
+let error (msg,pos) =
+ if pos.emin = pos.emax then
+ sprintf "%s line %d character %d" (error_msg msg) pos.eline (pos.emin - pos.eline_start)
+ else
+ sprintf "%s line %d characters %d-%d" (error_msg msg) pos.eline (pos.emin - pos.eline_start) (pos.emax - pos.eline_start)
+
+let line e = e.eline
+
+let range e =
+ e.emin - e.eline_start , e.emax - e.eline_start
+
+let abs_range e =
+ e.emin , e.emax
+
+let pos source =
+ let line, lstart, min, max = Xml_lexer.pos source in
+ {
+ eline = line;
+ eline_start = lstart;
+ emin = min;
+ emax = max;
+ }
\ No newline at end of file diff --git a/lib/xml_parser.mli b/lib/xml_parser.mli new file mode 100644 index 000000000..34dec792d --- /dev/null +++ b/lib/xml_parser.mli @@ -0,0 +1,115 @@ +(*
+ * Xml Light, an small Xml parser/printer with DTD support.
+ * Copyright (C) 2003 Nicolas Cannasse (ncannasse@motion-twin.com)
+ *
+ * This library 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; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library 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 library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+ *)
+
+(** Xml Light Parser
+
+ While basic parsing functions can be used in the {!Xml} module, this module
+ is providing a way to create, configure and run an Xml parser.
+
+*)
+
+
+(** An Xml node is either
+ [Element (tag-name, attributes, children)] or [PCData text] *)
+type xml =
+ | Element of (string * (string * string) list * xml list)
+ | PCData of string
+
+(** Abstract type for an Xml parser. *)
+type t
+
+(** {6:exc Xml Exceptions} *)
+
+(** Several exceptions can be raised when parsing an Xml document : {ul
+ {li {!Xml.Error} is raised when an xml parsing error occurs. the
+ {!Xml.error_msg} tells you which error occured during parsing
+ and the {!Xml.error_pos} can be used to retreive the document
+ location where the error occured at.}
+ {li {!Xml.File_not_found} is raised when and error occured while
+ opening a file with the {!Xml.parse_file} function.
+ }
+ *)
+
+type error_pos
+
+type error_msg =
+ | UnterminatedComment
+ | UnterminatedString
+ | UnterminatedEntity
+ | IdentExpected
+ | CloseExpected
+ | NodeExpected
+ | AttributeNameExpected
+ | AttributeValueExpected
+ | EndOfTagExpected of string
+ | EOFExpected
+
+type error = error_msg * error_pos
+
+exception Error of error
+
+exception File_not_found of string
+
+(** Get a full error message from an Xml error. *)
+val error : error -> string
+
+(** Get the Xml error message as a string. *)
+val error_msg : error_msg -> string
+
+(** Get the line the error occured at. *)
+val line : error_pos -> int
+
+(** Get the relative character range (in current line) the error occured at.*)
+val range : error_pos -> int * int
+
+(** Get the absolute character range the error occured at. *)
+val abs_range : error_pos -> int * int
+
+val pos : Lexing.lexbuf -> error_pos
+
+(** Several kind of resources can contain Xml documents. *)
+type source =
+ | SFile of string
+ | SChannel of in_channel
+ | SString of string
+ | SLexbuf of Lexing.lexbuf
+
+(** This function returns a new parser with default options. *)
+val make : unit -> t
+
+(** When a Xml document is parsed, the parser will check that the end of the
+ document is reached, so for example parsing ["<A/><B/>"] will fail instead
+ of returning only the A element. You can turn off this check by setting
+ [check_eof] to [false] {i (by default, check_eof is true)}. *)
+val check_eof : t -> bool -> unit
+
+(** Once the parser is configurated, you can run the parser on a any kind
+ of xml document source to parse its contents into an Xml data structure. *)
+val parse : t -> source -> xml
+
+(** When several PCData elements are separed by a \n (or \r\n), you can
+ either split the PCData in two distincts PCData or merge them with \n
+ as seperator into one PCData. The default behavior is to concat the
+ PCData, but this can be changed for a given parser with this flag. *)
+val concat_pcdata : t -> bool -> unit
+
+(**/**)
+
+(* internal usage only... *)
+val _raises : (error_msg -> Lexing.lexbuf -> exn) -> (string -> exn) -> unit
diff --git a/lib/xml_utils.ml b/lib/xml_utils.ml new file mode 100644 index 000000000..0a73cec09 --- /dev/null +++ b/lib/xml_utils.ml @@ -0,0 +1,229 @@ +(*
+ * Xml Light, an small Xml parser/printer with DTD support.
+ * Copyright (C) 2003 Nicolas Cannasse (ncannasse@motion-twin.com)
+ *
+ * This library 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; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library 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 library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+ *)
+
+open Printf
+open Xml_parser
+
+exception Not_element of xml
+exception Not_pcdata of xml
+exception No_attribute of string
+
+let default_parser = Xml_parser.make()
+
+let parse (p:Xml_parser.t) (source:Xml_parser.source) =
+ (* local cast Xml.xml -> xml *)
+ (Obj.magic Xml_parser.parse p source : xml)
+
+let parse_in ch = parse default_parser (Xml_parser.SChannel ch)
+let parse_string str = parse default_parser (Xml_parser.SString str)
+
+let parse_file f = parse default_parser (Xml_parser.SFile f)
+
+let tag = function
+ | Element (tag,_,_) -> tag
+ | x -> raise (Not_element x)
+
+let pcdata = function
+ | PCData text -> text
+ | x -> raise (Not_pcdata x)
+
+let attribs = function
+ | Element (_,attr,_) -> attr
+ | x -> raise (Not_element x)
+
+let attrib x att =
+ match x with
+ | Element (_,attr,_) ->
+ (try
+ let att = String.lowercase att in
+ snd (List.find (fun (n,_) -> String.lowercase n = att) attr)
+ with
+ Not_found ->
+ raise (No_attribute att))
+ | x ->
+ raise (Not_element x)
+
+let children = function
+ | Element (_,_,clist) -> clist
+ | x -> raise (Not_element x)
+
+(*let enum = function
+ | Element (_,_,clist) -> List.to_enum clist
+ | x -> raise (Not_element x)
+*)
+
+let iter f = function
+ | Element (_,_,clist) -> List.iter f clist
+ | x -> raise (Not_element x)
+
+let map f = function
+ | Element (_,_,clist) -> List.map f clist
+ | x -> raise (Not_element x)
+
+let fold f v = function
+ | Element (_,_,clist) -> List.fold_left f v clist
+ | x -> raise (Not_element x)
+
+let tmp = Buffer.create 200
+
+let buffer_pcdata text =
+ let l = String.length text in
+ for p = 0 to l-1 do
+ match text.[p] with
+ | '>' -> Buffer.add_string tmp ">"
+ | '<' -> Buffer.add_string tmp "<"
+ | '&' ->
+ if p < l-1 && text.[p+1] = '#' then
+ Buffer.add_char tmp '&'
+ else
+ Buffer.add_string tmp "&"
+ | '\'' -> Buffer.add_string tmp "'"
+ | '"' -> Buffer.add_string tmp """
+ | c -> Buffer.add_char tmp c
+ done
+
+let print_pcdata chan text =
+ let l = String.length text in
+ for p = 0 to l-1 do
+ match text.[p] with
+ | '>' -> Printf.fprintf chan ">"
+ | '<' -> Printf.fprintf chan "<"
+ | '&' ->
+ if p < l-1 && text.[p+1] = '#' then
+ Printf.fprintf chan "&"
+ else
+ Printf.fprintf chan "&"
+ | '\'' -> Printf.fprintf chan "'"
+ | '"' -> Printf.fprintf chan """
+ | c -> Printf.fprintf chan "%c" c
+ done
+
+let buffer_attr (n,v) =
+ Buffer.add_char tmp ' ';
+ Buffer.add_string tmp n;
+ Buffer.add_string tmp "=\"";
+ let l = String.length v in
+ for p = 0 to l-1 do
+ match v.[p] with
+ | '\\' -> Buffer.add_string tmp "\\\\"
+ | '"' -> Buffer.add_string tmp "\\\""
+ | c -> Buffer.add_char tmp c
+ done;
+ Buffer.add_char tmp '"'
+
+let rec print_attr chan (n, v) =
+ Printf.fprintf chan " %s=\"" n;
+ let l = String.length v in
+ for p = 0 to l-1 do
+ match v.[p] with
+ | '\\' -> Printf.fprintf chan "\\\\"
+ | '"' -> Printf.fprintf chan "\\\""
+ | c -> Printf.fprintf chan "%c" c
+ done;
+ Printf.fprintf chan "\""
+
+let print_attrs chan l = List.iter (print_attr chan) l
+
+let rec print_xml chan = function
+| Element (tag, alist, []) ->
+ Printf.fprintf chan "<%s%a/>" tag print_attrs alist;
+| Element (tag, alist, l) ->
+ Printf.fprintf chan "<%s%a>%a</%s>" tag print_attrs alist
+ (fun chan -> List.iter (print_xml chan)) l tag
+| PCData text ->
+ print_pcdata chan text
+
+let to_string x =
+ let pcdata = ref false in
+ let rec loop = function
+ | Element (tag,alist,[]) ->
+ Buffer.add_char tmp '<';
+ Buffer.add_string tmp tag;
+ List.iter buffer_attr alist;
+ Buffer.add_string tmp "/>";
+ pcdata := false;
+ | Element (tag,alist,l) ->
+ Buffer.add_char tmp '<';
+ Buffer.add_string tmp tag;
+ List.iter buffer_attr alist;
+ Buffer.add_char tmp '>';
+ pcdata := false;
+ List.iter loop l;
+ Buffer.add_string tmp "</";
+ Buffer.add_string tmp tag;
+ Buffer.add_char tmp '>';
+ pcdata := false;
+ | PCData text ->
+ if !pcdata then Buffer.add_char tmp ' ';
+ buffer_pcdata text;
+ pcdata := true;
+ in
+ Buffer.reset tmp;
+ loop x;
+ let s = Buffer.contents tmp in
+ Buffer.reset tmp;
+ s
+
+let to_string_fmt x =
+ let rec loop ?(newl=false) tab = function
+ | Element (tag,alist,[]) ->
+ Buffer.add_string tmp tab;
+ Buffer.add_char tmp '<';
+ Buffer.add_string tmp tag;
+ List.iter buffer_attr alist;
+ Buffer.add_string tmp "/>";
+ if newl then Buffer.add_char tmp '\n';
+ | Element (tag,alist,[PCData text]) ->
+ Buffer.add_string tmp tab;
+ Buffer.add_char tmp '<';
+ Buffer.add_string tmp tag;
+ List.iter buffer_attr alist;
+ Buffer.add_string tmp ">";
+ buffer_pcdata text;
+ Buffer.add_string tmp "</";
+ Buffer.add_string tmp tag;
+ Buffer.add_char tmp '>';
+ if newl then Buffer.add_char tmp '\n';
+ | Element (tag,alist,l) ->
+ Buffer.add_string tmp tab;
+ Buffer.add_char tmp '<';
+ Buffer.add_string tmp tag;
+ List.iter buffer_attr alist;
+ Buffer.add_string tmp ">\n";
+ List.iter (loop ~newl:true (tab^" ")) l;
+ Buffer.add_string tmp tab;
+ Buffer.add_string tmp "</";
+ Buffer.add_string tmp tag;
+ Buffer.add_char tmp '>';
+ if newl then Buffer.add_char tmp '\n';
+ | PCData text ->
+ buffer_pcdata text;
+ if newl then Buffer.add_char tmp '\n';
+ in
+ Buffer.reset tmp;
+ loop "" x;
+ let s = Buffer.contents tmp in
+ Buffer.reset tmp;
+ s
+
+;;
+Xml_parser._raises (fun x p ->
+ (* local cast : Xml.error_msg -> error_msg *)
+ Error (x, pos p))
+ (fun f -> File_not_found f);;
diff --git a/lib/xml_utils.mli b/lib/xml_utils.mli new file mode 100644 index 000000000..606e3182d --- /dev/null +++ b/lib/xml_utils.mli @@ -0,0 +1,93 @@ +(*
+ * Xml Light, an small Xml parser/printer with DTD support.
+ * Copyright (C) 2003 Nicolas Cannasse (ncannasse@motion-twin.com)
+ *
+ * This library 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; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library 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 library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+ *)
+
+(** Xml Light
+
+ Xml Light is a minimal Xml parser & printer for OCaml.
+ It provide few functions to parse a basic Xml document into
+ an OCaml data structure and to print back the data structures
+ to an Xml document.
+
+ Xml Light has also support for {b DTD} (Document Type Definition).
+
+ {i (c)Copyright 2002-2003 Nicolas Cannasse}
+*)
+
+open Xml_parser
+
+(** {6 Xml Functions} *)
+
+exception Not_element of xml
+exception Not_pcdata of xml
+exception No_attribute of string
+
+(** [tag xdata] returns the tag value of the xml node.
+ Raise {!Xml.Not_element} if the xml is not an element *)
+val tag : xml -> string
+
+(** [pcdata xdata] returns the PCData value of the xml node.
+ Raise {!Xml.Not_pcdata} if the xml is not a PCData *)
+val pcdata : xml -> string
+
+(** [attribs xdata] returns the attribute list of the xml node.
+ First string if the attribute name, second string is attribute value.
+ Raise {!Xml.Not_element} if the xml is not an element *)
+val attribs : xml -> (string * string) list
+
+(** [attrib xdata "href"] returns the value of the ["href"]
+ attribute of the xml node (attribute matching is case-insensitive).
+ Raise {!Xml.No_attribute} if the attribute does not exists in the node's
+ attribute list
+ Raise {!Xml.Not_element} if the xml is not an element *)
+val attrib : xml -> string -> string
+
+(** [children xdata] returns the children list of the xml node
+ Raise {!Xml.Not_element} if the xml is not an element *)
+val children : xml -> xml list
+
+(*** [enum xdata] returns the children enumeration of the xml node
+ Raise {!Xml.Not_element} if the xml is not an element *)
+(* val enum : xml -> xml Enum.t *)
+
+(** [iter f xdata] calls f on all children of the xml node.
+ Raise {!Xml.Not_element} if the xml is not an element *)
+val iter : (xml -> unit) -> xml -> unit
+
+(** [map f xdata] is equivalent to [List.map f (Xml.children xdata)]
+ Raise {!Xml.Not_element} if the xml is not an element *)
+val map : (xml -> 'a) -> xml -> 'a list
+
+(** [fold f init xdata] is equivalent to
+ [List.fold_left f init (Xml.children xdata)]
+ Raise {!Xml.Not_element} if the xml is not an element *)
+val fold : ('a -> xml -> 'a) -> 'a -> xml -> 'a
+
+(** {6 Xml Printing} *)
+
+(** Print the xml data structure to a channel into a compact xml string (without
+ any user-readable formating ). *)
+val print_xml : out_channel -> xml -> unit
+
+(** Print the xml data structure into a compact xml string (without
+ any user-readable formating ). *)
+val to_string : xml -> string
+
+(** Print the xml data structure into an user-readable string with
+ tabs and lines break between different nodes. *)
+val to_string_fmt : xml -> string
|