src/tag.ml

   1 (******************************************************************************)
   2 (*  SXSI : XPath evaluator                                                    *)
   3 (*  Kim Nguyen (Kim.Nguyen@nicta.com.au)                                      *)
   4 (*  Copyright NICTA 2008                                                      *)
   5 (*  Distributed under the terms of the LGPL (see LICENCE)                     *)
   6 (******************************************************************************)
   7 (*  maybe utf8 string... *)
   8
   9
  10 type t = int
  11 type pool
  12
  13 type operations = {
  14   tag : pool -> string -> t;
  15   to_string : pool -> t ->string;
  16   nullt : pool -> t;
  17   translate : pool -> t -> t
  18 }
  19
  20 let dummy_fun =function _ -> failwith "Tag.ml Uninitialized tag structure"
  21
  22
  23
  24
  25 external null_pool : unit -> pool = "caml_xml_tree_nullt"
  26 external null_tag : unit -> t = "caml_xml_tree_nullt"
  27 external register_tag : pool -> string -> t = "caml_xml_tree_register_tag"
  28 external tag_name : pool -> t -> string = "caml_xml_tree_get_tag_name"
  29 external num_tags : pool -> int = "caml_xml_tree_num_tags"
  30 let nullt = null_tag ()
  31 let dummy = nullt
  32 (* Defined in XMLTree.cpp *)
  33 let document_node = 0
  34 let attribute = 1
  35 let pcdata = 2
  36 let attribute_data= 3
  37 let document_node_close = 4
  38 let attribute_close = 5
  39 let pcdata_close = 6
  40 let attribute_data_close= 7
  41
  42
  43 let pool = Weak.create 1
  44
  45 let init p = Weak.set pool 0 (Some p)
  46
  47 let get_pool () =  match Weak.get pool 0 with
  48   | Some x -> x
  49   | None -> failwith "Tag.ml: Uninitialized Document"
  50
  51 let tag s = match s with
  52   | "<$>" -> pcdata
  53   | "<@>" -> attribute
  54   | "" -> document_node
  55   | "<@$>" -> attribute_data
  56   | _ -> register_tag (get_pool()) s
  57
  58 let compare = (-)
  59 let equal = (==)
  60
  61 let hash x = x
  62
  63 let to_string t =
  64   if t == pcdata then "<$>"
  65   else if t == attribute_data then "<@$>"
  66   else if t == attribute then "<@>"
  67   else if t == nullt then "<!NIL!>"
  68   else tag_name (get_pool()) t
  69
  70
  71 let xml_operations = {
  72   tag = (fun _ x -> tag x);
  73   to_string = (fun _ x -> to_string x);
  74   nullt = (fun _ -> nullt);
  75   translate = (fun _ x -> x);
  76 }
  77
  78
  79
  80
  81 let dump_tags () =
  82   Format.eprintf "Tags are:\n";
  83   let doc = get_pool() in
  84   let ntags = num_tags doc in
  85     for i = 0 to ntags - 1 do
  86       Format.eprintf "%i, -><%s/>\n%!" i (to_string i)
  87     done
  88
  89
  90
  91 let print ppf t = Format.fprintf ppf "%s" (to_string t)
  92 (* Check internal invariants *)
  93 let check t =
  94   if (t != tag (to_string t))
  95   then failwith "module Tag: internal check failed"
  96
  97 let dump = print
  98