Commits

jhwoodyatt  committed dd4ffaf

Initial submit of OCaml NAE XML Support Library.

  • Participants
  • Parent commits 4a30d44

Comments (0)

Files changed (1)

File xml/t/t_xml.ml

+(*---------------------------------------------------------------------------*
+  IMPLEMENTATION  t_xml.ml
+
+  Copyright (c) 2003-2004, James H. Woodyatt
+  All rights reserved.
+
+  Redistribution and use in source and binary forms, with or without
+  modification, are permitted provided that the following conditions
+  are met:
+
+    Redistributions of source code must retain the above copyright
+    notice, this list of conditions and the following disclaimer.
+
+    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
+
+  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 HOLDERS 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. 
+ *---------------------------------------------------------------------------*)
+
+Random.self_init ();;
+
+(*
+Gc.set {
+    (Gc.get ()) with
+    (* Gc.verbose = 0x3ff; *)
+    Gc.verbose = 0x14;
+};;
+
+Gc.create_alarm begin fun () ->
+    let min, pro, maj = Gc.counters () in
+    Printf.printf "[Gc] minor=%f promoted=%f major=%f\n" min pro maj;
+    flush stdout
+end
+*)
+
+module type X_tag = sig
+    val tag: string
+end
+
+module X_create(T: X_tag) = struct
+    let tag = Printf.sprintf "[%s] " T.tag
+
+    let printf fmt =
+        print_string tag;
+        Printf.printf fmt
+    
+    let sprintf (fmt : ('a, unit, string) format) =
+        Printf.sprintf (Obj.magic (tag ^ (Obj.magic fmt)))
+end
+
+module T1 = struct
+    module X = X_create(struct let tag = "T1" end)
+
+    open Xml_expat
+    
+    let test_error () =
+        let factory = parser_factory () in
+        try
+            let p = parser_create factory in
+            parse_string p "foo" Final;
+            failwith "Expected to raise exception"
+        with
+        | Error ERROR_SYNTAX ->
+            ()
+        | Error code ->
+            failwith (error_string code)
+    
+    let test_basic1 () =
+        let document =
+           "<?xml version=\"1.0\" encoding='utf-8' standalone='yes'?>\r\n\
+            <foo bar='baz' BAZ=\"bimmer!\">\r\n\
+                this is a test!\r\n\
+                <![CDATA[<start/>]]>\r\n\
+                <bar/>\r\n\
+                <?bim bam boom?>\r\n\
+                <baz p='NMTOKEN NMTOKEN   NMTOKEN &#x25;' \t q='1'/>\r\n\
+            </foo>\r\n"
+        in
+        let factory = parser_factory () in
+        (*
+        let preamble ~p =
+            let x1, x2, x3 ,x4 =
+                get_current_byte_index p,
+                get_current_byte_count p,
+                get_current_column_number p,
+                get_current_line_number p
+            in
+            X.printf " {i=%nd,n=%nd,c=%nd,l=%nd}:\t" x1 x2 x3 x4
+        in
+        *)
+        let startHandler ~p tag attr =
+            (*
+            preamble ~p;
+            Printf.printf "<%s" tag;
+            List.iter (fun (n, v) -> Printf.printf " %s='%s'" n v) attr;
+            Printf.printf ">\n";
+            flush stdout;
+            *)
+            ()
+        and endHandler ~p tag =
+            (*
+            preamble ~p;
+            Printf.printf "</%s>\n" tag;
+            flush stdout
+            *)
+            ()
+        and characterDataHandler ~p data =
+            (*
+            preamble ~p;
+            Printf.printf "%s\n" data;
+            flush stdout
+            *)
+            ()
+        and xmlDeclHandler ~p ?version ?encoding standalone =
+            (*
+            preamble ~p;
+            Printf.printf "<?xml";
+            begin
+                match version with
+                | Some str -> Printf.printf " version='%s'" str
+                | None -> ()
+            end;
+            begin
+                match encoding with
+                | Some str -> Printf.printf " encoding='%s'" str
+                | None -> ()
+            end;
+            begin
+                match standalone with
+                | SA_implied -> ()
+                | SA_no -> Printf.printf " standalone='no'"
+                | SA_yes -> Printf.printf " standalone='yes'"
+            end;
+            Printf.printf "?>\n";
+            flush stdout
+            *)
+            ()
+        and processingInstructionHandler ~p target data =
+            (*
+            preamble ~p;
+            Printf.printf "<?%s %s?>\n" target data;
+            flush stdout
+            *)
+            ()
+        in
+        try
+            let p = parser_create factory in
+            (*
+            preamble p;
+            Printf.printf "//\\//\\//\\//\\//\\//\\ begin\n";
+            flush stdout;
+            *)
+            set_handler_element_start p (Some (startHandler ~p));
+            set_handler_element_end p (Some (endHandler ~p));
+            set_handler_character_data p (Some (characterDataHandler ~p));
+            set_handler_processing_instruction
+                p (Some (processingInstructionHandler ~p));
+            set_handler_xml_decl p (Some (xmlDeclHandler ~p));
+            parse_string p document Final;
+            (*
+            preamble p;
+            Printf.printf "//\\//\\//\\//\\//\\//\\ end\n";
+            flush stdout;
+            *)
+            parser_recycle factory p
+        with
+        | Error code ->
+            failwith (error_string code)
+        
+    
+    let test () =
+        test_error ();
+        test_basic1 ()
+end
+
+module T2 = struct
+    module X = X_create(struct let tag = "T2" end)
+
+    open Cf_parser.Op
+    
+    type validator_foo_t = {
+        v_att_const_: int option;
+        v_att_array_: string list option;
+    }
+    
+    let rec const_parser acc seq =
+        match Lazy.force seq with
+        | Cf_seq.Z ->
+            Some (acc, seq)
+        | Cf_seq.P ('0' .. '9' as hd, tl) ->
+            let acc' = acc * 10 in
+            if acc = 0 || acc' / acc = 10 then
+               const_parser (acc' + ((int_of_char hd) - (int_of_char '0'))) tl
+            else
+                None
+        | Cf_seq.P (hd, tl) ->
+            None
+    
+    let foo_element =
+        let tag = "foo" in
+        let content v = ~:v in
+        let attr pos acc (key, attval as pair) =
+            let p =
+                match key with
+                | "const" -> begin fun v ->
+                        const_parser 0 >>= fun n ->
+                        Cf_parser.fin >>= fun () ->
+                        ~:{ v with v_att_const_ = Some n }
+                    end
+                | "array" -> begin fun v ->
+                        Xml_parser.split_attribute_value >>= fun arr ->
+                        Cf_parser.fin >>= fun () ->
+                        ~:{ v with v_att_array_ = Some arr }
+                    end
+                | _ -> begin fun _ -> Cf_parser.nil end
+            in
+            match p acc (Cf_seq.of_string attval) with
+            | None ->
+                let event = Xml_event.T_element_start ("foo", [pair]), pos in
+                raise (Xml_parser.Invalid event)
+            | Some (v, _) ->
+                v
+        in
+        let v = {
+            v_att_const_ = None;
+            v_att_array_ = None;
+        } in
+        Xml_parser.validated_element ~tag ~attr ~content v >>= fun v ->
+        Xml_parser.optional_whitespace >>= fun () ->
+        Xml_parser.end_of_document >>= fun () ->
+        Cf_parser.fin >>= fun () ->
+        match v.v_att_const_, v.v_att_array_ with
+        | Some const, Some array -> ~:(`Foo (const, array))
+        | _, _ -> Cf_parser.nil
+    
+    let foo = "<foo const='123' array='bim bam  boom &#x25;'/>"
+    
+    let test () =
+        let f = Xml_expat.parser_factory () in
+        let m = Cf_message.create foo in
+        let s = Xml_event.stream f m in
+        match foo_element s with
+        | None ->
+            failwith (X.sprintf "Not matched!")
+        | Some (`Foo (const, array), _) ->
+            if const <> 123 && array <> ["bim";"bam";"boom";"%"] then
+                failwith (X.sprintf "Attributes error!")
+end
+
+let main () =
+    let tests = [
+        T1.test; T2.test
+    ] in
+    Printf.printf "1..%d\n" (List.length tests);
+    flush stdout;
+        
+    let test i f =
+        begin
+            try
+                f ();
+                Printf.printf "ok %d\n" i
+            with
+            | Failure(s) ->
+                Printf.printf "not ok %d (Failure \"%s\")\n" i s
+            | x ->
+                Printf.printf "not ok %d\n" i;
+                flush stdout;
+                raise x
+        end;
+        flush stdout;
+        succ i
+    in
+    let _ = List.fold_left test 1 tests in
+    exit 0
+;;
+
+main ();;
+
+
+(*--- End of File [ t_xml.ml ] ---*)