helm/DEVEL/pxp/pxp/rtests/canonxml/test_canonxml.ml

   1 (* $Id$
   2  * ----------------------------------------------------------------------
   3  *
   4  *)
   5
   6
   7 open Pxp_document;;
   8 open Pxp_yacc;;
   9 open Pxp_types;;
  10
  11 let error_happened = ref false;;
  12
  13 let rec prerr_error e =
  14   prerr_endline (string_of_exn e)
  15 ;;
  16
  17 class warner =
  18   object
  19     method warn w =
  20       prerr_endline ("WARNING: " ^ w)
  21   end
  22 ;;
  23
  24 let outbuf = String.create 8192;;
  25
  26 let output_utf8 config s =
  27   match config.encoding  with
  28       `Enc_utf8 ->
  29         print_string s
  30     | `Enc_iso88591 ->
  31         for i = 0 to String.length s - 1 do
  32           let c = Char.code(s.[i]) in
  33           if c <= 127 then
  34             print_char(Char.chr(c))
  35           else begin
  36             print_char(Char.chr(0xc0 lor (c lsr 6)));
  37             print_char(Char.chr(0x80 lor (c land 0x3f)));
  38           end
  39         done
  40     | _ -> assert false
  41 ;;
  42
  43
  44 let re = Str.regexp "[&<>\"\009\010\013]";;
  45
  46 let escaped s =
  47   Str.global_substitute
  48     re
  49     (fun _ ->
  50        match Str.matched_string s with
  51            "&"    -> "&amp;"
  52          | "<"    -> "&lt;"
  53          | ">"    -> "&gt;"
  54          | "\""   -> "&quot;"
  55          | "\009" -> "&#9;"
  56          | "\010" -> "&#10;"
  57          | "\013" -> "&#13;"
  58          | _      -> assert false
  59     )
  60     s
  61 ;;
  62
  63
  64 let rec output_xml config n =
  65   match n # node_type with
  66       T_super_root ->
  67         n # iter_nodes (output_xml config)
  68     | T_pinstr pi_name ->
  69         let [ pi ] = n # pinstr pi_name in
  70         output_utf8 config "<?";
  71         output_utf8 config (pi # target);
  72         output_utf8 config " ";
  73         output_utf8 config (pi # value);
  74         output_utf8 config "?>";
  75     | T_element name ->
  76         output_utf8 config "<";
  77         output_utf8 config name;
  78         let sorted_attnames =
  79           Sort.list ( <= ) (n # attribute_names) in
  80         List.iter
  81           (fun attname ->
  82              match n # attribute attname with
  83                  Value v ->
  84                    output_utf8 config " ";
  85                    output_utf8 config attname;
  86                    output_utf8 config "=\"";
  87                    output_utf8 config (escaped v);
  88                    output_utf8 config "\"";
  89                | Valuelist vl ->
  90                    let v = String.concat " " vl in
  91                    output_utf8 config " ";
  92                    output_utf8 config attname;
  93                    output_utf8 config "=\"";
  94                    output_utf8 config (escaped v);
  95                    output_utf8 config "\"";
  96                | Implied_value ->
  97                    ()
  98           )
  99           sorted_attnames;
 100         output_utf8 config ">";
 101         n # iter_nodes (output_xml config);
 102         output_utf8 config "</";
 103         output_utf8 config name;
 104         output_utf8 config ">";
 105     | T_data ->
 106         let v = n # data in
 107         output_utf8 config (escaped v)
 108     | T_comment ->
 109         let v =
 110           match n # comment with
 111               None -> assert false
 112             | Some x -> x
 113         in
 114         output_utf8 config ("<!--" ^ v ^ "-->")
 115     | _ ->
 116         assert false
 117 ;;
 118
 119
 120 let parse debug wf iso88591 comments filename =
 121   let spec =
 122     let e = new element_impl default_extension in
 123     e # keep_always_whitespace_mode;
 124     make_spec_from_mapping
 125       ~super_root_exemplar:      e
 126       ~default_pinstr_exemplar:  e
 127       ~comment_exemplar:         e
 128       ~data_exemplar:            (new data_impl default_extension)
 129       ~default_element_exemplar: e
 130       ~element_mapping:          (Hashtbl.create 1)
 131       ()
 132   in
 133   let config =
 134       { default_config with
 135           warner = new warner;
 136           debugging_mode = debug;
 137           enable_pinstr_nodes = true;
 138           enable_super_root_node = true;
 139           enable_comment_nodes = comments;
 140           encoding = if iso88591 then `Enc_iso88591 else `Enc_utf8;
 141           idref_pass = true;
 142       }
 143   in
 144   try
 145     let parse_fn =
 146       if wf then parse_wfdocument_entity
 147       else
 148         let index = new hash_index in
 149         parse_document_entity
 150           ?transform_dtd:None
 151           ~id_index:(index :> 'ext index)
 152     in
 153     let tree =
 154       parse_fn
 155         config
 156         (from_file filename)
 157         spec
 158     in
 159     output_xml config (tree # root)
 160   with
 161       e ->
 162         error_happened := true;
 163         prerr_error e
 164 ;;
 165
 166
 167 let main() =
 168   let debug = ref false in
 169   let wf = ref false in
 170   let iso88591 = ref false in
 171   let comments = ref false in
 172   let files = ref [] in
 173   Arg.parse
 174       [ "-d",   Arg.Set debug,
 175            "          turn debugging mode on";
 176         "-wf",  Arg.Set wf,
 177             "         check only on well-formedness";
 178         "-iso-8859-1", Arg.Set iso88591,
 179                     " use ISO-8859-1 as internal encoding instead of UTF-8";
 180         "-comments", Arg.Set comments,
 181                   "   output comments, too";
 182       ]
 183       (fun x -> files := x :: !files)
 184       "
 185 usage: test_canonxml [options] file ...
 186
 187 List of options:";
 188   files := List.rev !files;
 189   List.iter (parse !debug !wf !iso88591 !comments) !files;
 190 ;;
 191
 192
 193 main();
 194 if !error_happened then exit(1);;
 195
 196 (* ======================================================================
 197  * History:
 198  *
 199  * $Log$
 200  * Revision 1.1  2000/11/17 09:57:32  lpadovan
 201  * Initial revision
 202  *
 203  * Revision 1.8  2000/08/17 00:51:57  gerd
 204  *      Added -comments option to test enable_comment_nodes.
 205  *
 206  * Revision 1.7  2000/08/16 23:44:17  gerd
 207  *      Updates because of changes of the PXP API.
 208  *
 209  * Revision 1.6  2000/07/14 14:56:55  gerd
 210  *      Updated: warner.
 211  *
 212  * Revision 1.5  2000/07/14 14:17:58  gerd
 213  *      Updated because of iterface changes.
 214  *
 215  * Revision 1.4  2000/07/09 01:06:20  gerd
 216  *      Updated.
 217  *
 218  * Revision 1.3  2000/06/04 20:31:03  gerd
 219  *      Updates because of renamed PXP modules.
 220  *
 221  * Revision 1.2  2000/05/20 20:34:28  gerd
 222  *      Changed for UTF-8 support.
 223  *
 224  * Revision 1.1  2000/04/30 20:13:01  gerd
 225  *      Initial revision.
 226  *
 227  * Revision 1.3  1999/11/09 22:27:30  gerd
 228  *      The programs returns now an exit code of 1 if one of the
 229  * XML files produces an error.
 230  *
 231  * Revision 1.2  1999/09/01 23:09:56  gerd
 232  *      Added the option -wf that switches to well-formedness checking
 233  * instead of validation.
 234  *
 235  * Revision 1.1  1999/08/14 22:20:53  gerd
 236  *      Initial revision.
 237  *
 238  *
 239  *)