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 external null_pool : unit -> pool = "caml_xml_tree_nullt"
  21 external null_tag : unit -> t = "caml_xml_tree_nullt"
  22 external register_tag : pool -> string -> t = "caml_xml_tree_register_tag"
  23 external tag_name : pool -> t -> string = "caml_xml_tree_get_tag_name"
  24 external num_tags : pool -> int = "caml_xml_tree_num_tags"
  25 let nullt = null_tag ()
  26 let dummy = nullt
  27 (* Defined in XMLTree.cpp *)
  28 let document_node = 0
  29 let attribute = 1
  30 let pcdata = 2
  31 let attribute_data= 3
  32 let document_node_close = 4
  33 let attribute_close = 5
  34 let pcdata_close = 6
  35 let attribute_data_close= 7
  36
  37
  38 let pool = Weak.create 1
  39
  40 let init p = Weak.set pool 0 (Some p)
  41
  42 let get_pool () =  match Weak.get pool 0 with
  43   | Some x -> x
  44   | None -> failwith "Tag.ml: Uninitialized Document"
  45
  46 let tag s = match s with
  47   | "<$>" -> pcdata
  48   | "<@>" -> attribute
  49   | "" -> document_node
  50   | "<@$>" -> attribute_data
  51   | _ -> register_tag (get_pool()) s
  52
  53 let compare = (-)
  54 let equal = (==)
  55
  56 let hash x = x
  57
  58 let to_string t =
  59   if t == pcdata then "<$>"
  60   else if t == attribute_data then "<@$>"
  61   else if t == attribute then "<@>"
  62   else if t == nullt then "<!NIL!>"
  63   else tag_name (get_pool()) t
  64
  65
  66 let xml_operations = {
  67   tag = (fun _ x -> tag x);
  68   to_string = (fun _ x -> to_string x);
  69   nullt = (fun _ -> nullt);
  70   translate = (fun _ x -> x);
  71 }
  72
  73
  74
  75
  76 let dump_tags () =
  77   Format.eprintf "Tags are:\n";
  78   let doc = get_pool() in
  79   let ntags = num_tags doc in
  80     for i = 0 to ntags - 1 do
  81       Format.eprintf "%i, -><%s/>\n%!" i (to_string i)
  82     done
  83
  84
  85
  86 let print ppf t = Format.fprintf ppf "%s" (to_string t)
  87 (* Check internal invariants *)
  88 let check t =
  89   if (t != tag (to_string t))
  90   then failwith "module Tag: internal check failed"
  91
  92 let dump = print
  93