--- /dev/null
+(* $Id$
+ * ----------------------------------------------------------------------
+ *
+ *)
+
+
+open Pxp_document;;
+open Pxp_yacc;;
+open Pxp_types;;
+
+let error_happened = ref false;;
+
+let rec prerr_error e =
+ prerr_endline (string_of_exn e)
+;;
+
+class warner =
+ object
+ method warn w =
+ prerr_endline ("WARNING: " ^ w)
+ end
+;;
+
+let outbuf = String.create 8192;;
+
+let output_utf8 config s =
+ match config.encoding with
+ `Enc_utf8 ->
+ print_string s
+ | `Enc_iso88591 ->
+ for i = 0 to String.length s - 1 do
+ let c = Char.code(s.[i]) in
+ if c <= 127 then
+ print_char(Char.chr(c))
+ else begin
+ print_char(Char.chr(0xc0 lor (c lsr 6)));
+ print_char(Char.chr(0x80 lor (c land 0x3f)));
+ end
+ done
+ | _ -> assert false
+;;
+
+
+let re = Str.regexp "[&<>\"\009\010\013]";;
+
+let escaped s =
+ Str.global_substitute
+ re
+ (fun _ ->
+ match Str.matched_string s with
+ "&" -> "&"
+ | "<" -> "<"
+ | ">" -> ">"
+ | "\"" -> """
+ | "\009" -> "	"
+ | "\010" -> " "
+ | "\013" -> " "
+ | _ -> assert false
+ )
+ s
+;;
+
+
+let rec output_xml config n =
+ match n # node_type with
+ T_super_root ->
+ n # iter_nodes (output_xml config)
+ | T_pinstr pi_name ->
+ let [ pi ] = n # pinstr pi_name in
+ output_utf8 config "<?";
+ output_utf8 config (pi # target);
+ output_utf8 config " ";
+ output_utf8 config (pi # value);
+ output_utf8 config "?>";
+ | T_element name ->
+ output_utf8 config "<";
+ output_utf8 config name;
+ let sorted_attnames =
+ Sort.list ( <= ) (n # attribute_names) in
+ List.iter
+ (fun attname ->
+ match n # attribute attname with
+ Value v ->
+ output_utf8 config " ";
+ output_utf8 config attname;
+ output_utf8 config "=\"";
+ output_utf8 config (escaped v);
+ output_utf8 config "\"";
+ | Valuelist vl ->
+ let v = String.concat " " vl in
+ output_utf8 config " ";
+ output_utf8 config attname;
+ output_utf8 config "=\"";
+ output_utf8 config (escaped v);
+ output_utf8 config "\"";
+ | Implied_value ->
+ ()
+ )
+ sorted_attnames;
+ output_utf8 config ">";
+ n # iter_nodes (output_xml config);
+ output_utf8 config "</";
+ output_utf8 config name;
+ output_utf8 config ">";
+ | T_data ->
+ let v = n # data in
+ output_utf8 config (escaped v)
+ | T_comment ->
+ let v =
+ match n # comment with
+ None -> assert false
+ | Some x -> x
+ in
+ output_utf8 config ("<!--" ^ v ^ "-->")
+ | _ ->
+ assert false
+;;
+
+
+let parse debug wf iso88591 comments filename =
+ let spec =
+ let e = new element_impl default_extension in
+ e # keep_always_whitespace_mode;
+ make_spec_from_mapping
+ ~super_root_exemplar: e
+ ~default_pinstr_exemplar: e
+ ~comment_exemplar: e
+ ~data_exemplar: (new data_impl default_extension)
+ ~default_element_exemplar: e
+ ~element_mapping: (Hashtbl.create 1)
+ ()
+ in
+ let config =
+ { default_config with
+ warner = new warner;
+ debugging_mode = debug;
+ enable_pinstr_nodes = true;
+ enable_super_root_node = true;
+ enable_comment_nodes = comments;
+ encoding = if iso88591 then `Enc_iso88591 else `Enc_utf8;
+ idref_pass = true;
+ }
+ in
+ try
+ let parse_fn =
+ if wf then parse_wfdocument_entity
+ else
+ let index = new hash_index in
+ parse_document_entity
+ ?transform_dtd:None
+ ~id_index:(index :> 'ext index)
+ in
+ let tree =
+ parse_fn
+ config
+ (from_file filename)
+ spec
+ in
+ output_xml config (tree # root)
+ with
+ e ->
+ error_happened := true;
+ prerr_error e
+;;
+
+
+let main() =
+ let debug = ref false in
+ let wf = ref false in
+ let iso88591 = ref false in
+ let comments = ref false in
+ let files = ref [] in
+ Arg.parse
+ [ "-d", Arg.Set debug,
+ " turn debugging mode on";
+ "-wf", Arg.Set wf,
+ " check only on well-formedness";
+ "-iso-8859-1", Arg.Set iso88591,
+ " use ISO-8859-1 as internal encoding instead of UTF-8";
+ "-comments", Arg.Set comments,
+ " output comments, too";
+ ]
+ (fun x -> files := x :: !files)
+ "
+usage: test_canonxml [options] file ...
+
+List of options:";
+ files := List.rev !files;
+ List.iter (parse !debug !wf !iso88591 !comments) !files;
+;;
+
+
+main();
+if !error_happened then exit(1);;
+
+(* ======================================================================
+ * History:
+ *
+ * $Log$
+ * Revision 1.1 2000/11/17 09:57:32 lpadovan
+ * Initial revision
+ *
+ * Revision 1.8 2000/08/17 00:51:57 gerd
+ * Added -comments option to test enable_comment_nodes.
+ *
+ * Revision 1.7 2000/08/16 23:44:17 gerd
+ * Updates because of changes of the PXP API.
+ *
+ * Revision 1.6 2000/07/14 14:56:55 gerd
+ * Updated: warner.
+ *
+ * Revision 1.5 2000/07/14 14:17:58 gerd
+ * Updated because of iterface changes.
+ *
+ * Revision 1.4 2000/07/09 01:06:20 gerd
+ * Updated.
+ *
+ * Revision 1.3 2000/06/04 20:31:03 gerd
+ * Updates because of renamed PXP modules.
+ *
+ * Revision 1.2 2000/05/20 20:34:28 gerd
+ * Changed for UTF-8 support.
+ *
+ * Revision 1.1 2000/04/30 20:13:01 gerd
+ * Initial revision.
+ *
+ * Revision 1.3 1999/11/09 22:27:30 gerd
+ * The programs returns now an exit code of 1 if one of the
+ * XML files produces an error.
+ *
+ * Revision 1.2 1999/09/01 23:09:56 gerd
+ * Added the option -wf that switches to well-formedness checking
+ * instead of validation.
+ *
+ * Revision 1.1 1999/08/14 22:20:53 gerd
+ * Initial revision.
+ *
+ *
+ *)
projects / helm.git / blobdiff