1. james woodyatt
  2. oni

Source

oni / xml / t / t_xml.ml

(*---------------------------------------------------------------------------*
  $Change$
  Copyright (c) 2003-2010, 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 ();;

let jout = Cf_journal.stdout
(* let _ = jout#setlimit `None *)

(*
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: unit -> ('a, 'b, 'c, 'a) format4
end

module type X = sig
    val bprintf: Buffer.t -> ('a, Buffer.t, unit, unit) format4 -> 'a
    val sprintf: ('a, unit, string) format -> 'a
end

module X_create(T: X_tag): X = struct
    let bprintf b fmt =
        let tag = "[" ^^ (T.tag ()) ^^ "] " in
        Printf.bprintf b (tag ^^ fmt)
    
    let sprintf fmt =
        let tag = "[" ^^ (T.tag ()) ^^ "] " in
        Printf.sprintf (tag ^^ fmt)
end

module T1 = struct
    module X = X_create(struct let tag () = format_of_string "T1" end)
    
    open Xml_expat
    
    let test_error () =
        let factory = parser_factory () in
        let p = parser_create factory in
        try
            parse_string p "foo" Final;
            failwith "Expected to raise exception"
        with
        | Error ERROR_SYNTAX ->
            parser_recycle factory p
        | Error code ->
            parser_recycle factory p;
            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
            let b = Buffer.create 80 in
            X.bprintf b " {i=%nd,n=%nd,c=%nd,l=%nd}:\t" x1 x2 x3 x4;
            b
        in
        let startHandler ~p tag attr =
            assert begin
                let b = preamble ~p in
                Printf.bprintf b "<%s" tag;
                List.iter (fun (n, v) -> Printf.bprintf b " %s='%s'" n v) attr;
                Printf.bprintf b ">\n";
                jout#debug "%s" (Buffer.contents b)
            end
        and endHandler ~p tag =
            assert begin
                let b = preamble ~p in
                Printf.bprintf b "</%s>\n" tag;
                jout#debug "%s" (Buffer.contents b)
            end
        and characterDataHandler ~p data =
            assert begin
                let b = preamble ~p in
                Printf.bprintf b "%s\n" data;
                jout#debug "%s" (Buffer.contents b)
            end
        and xmlDeclHandler ~p ?version ?encoding standalone =
            assert begin
                let b = preamble ~p in
                Printf.bprintf b "<?xml";
                begin
                    match version with
                    | Some str -> Printf.bprintf b " version='%s'" str
                    | None -> ()
                end;
                begin
                    match encoding with
                    | Some str -> Printf.bprintf b " encoding='%s'" str
                    | None -> ()
                end;
                begin
                    match standalone with
                    | SA_implied -> ()
                    | SA_no -> Printf.bprintf b " standalone='no'"
                    | SA_yes -> Printf.bprintf b " standalone='yes'"
                end;
                Printf.bprintf b "?>\n";
                jout#debug "%s" (Buffer.contents b)
            end
        and processingInstructionHandler ~p target data =
            assert begin
                let b = preamble ~p in
                Printf.bprintf b "<?%s %s?>\n" target data;
                jout#debug "%s" (Buffer.contents b)
            end
        in
        let p = parser_create factory in
        try
            assert begin
                let b = preamble ~p in
                Printf.bprintf b "//\\//\\//\\//\\//\\//\\ begin\n";
                jout#debug "%s" (Buffer.contents b);
            end;
            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;
            assert begin
                let b = preamble ~p in
                Printf.bprintf b "//\\//\\//\\//\\//\\//\\ end\n";
                jout#debug "%s" (Buffer.contents b);
            end;
            parser_recycle factory p
        with
        | Error code ->
            parser_recycle factory p;
            failwith (error_string code)        
    
    let test () =
        test_error ();
        test_basic1 ()
end

module T2 = struct
    module X = X_create(struct let tag () = format_of_string "T2" end)
    
    open Cf_llscan.Op
    
    type validator_foo = {
        v_att_const_: int option;
        v_att_array_: string list option;
        v_content_: string;
    }
    
    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 _ ->
            None
    
    let foo_element =
        let tag = "foo" in
        let content v =
            Xml_parser.accumulated_character_data >>= fun msg ->
            let data = Cf_message.contents msg in
            Cf_llscan.ret { v with v_content_ = data }
        in
        let attr pos acc (key, attval as pair) =
            let p =
                match key with
                | "const" -> begin fun v ->
                        const_parser 0 >>= fun n ->
                        Cf_llscan.fin >>= fun () ->
                        Cf_llscan.ret { v with v_att_const_ = Some n }
                    end
                | "array" -> begin fun v ->
                        Xml_parser.split_attribute_value >>= fun arr ->
                        Cf_llscan.fin >>= fun () ->
                        Cf_llscan.ret { v with v_att_array_ = Some arr }
                    end
                | _ -> begin fun _ -> Cf_llscan.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;
            v_content_ = "";
        } in
        Xml_parser.validated_element ~tag ~attr ~content v >>= fun v ->
        Xml_parser.optional_whitespace >>= fun () ->
        Xml_parser.end_of_document >>= fun () ->
        Cf_llscan.fin >>= fun () ->
        match v.v_att_const_, v.v_att_array_ with
        | Some const, Some array ->
            Cf_llscan.ret (`Foo (const, array, v.v_content_))
        | _, _ ->
            Cf_llscan.nil
    
    let foo =
        "<foo const='123' array='bim bam  boom &#x25;'>\r\n" ^
        "  <![CDATA[<blob>abcdef</blob>]]>\r\n" ^
        "</foo>"
    
    let test_inner_ () =
        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, content), _) ->
            if
                const <> 123 && array <> ["bim";"bam";"boom";"%"] &&
                content <> "<blob>abcdef</blob>"
            then
                failwith (X.sprintf "Attributes error!")
    
    let test () =
        try test_inner_ () with
        | Xml_parser.Invalid (token, position) ->
            failwith (X.sprintf "Parse error @ %s line %nu, col %nu"
                (Xml_event.token_to_string token)
                position.Xml_event.pos_line_number
                position.Xml_event.pos_column_number)
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 ();;

(*--- $File$ ---*)