Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 283 lines (252 sloc) 8.872 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282
(*
Copyright © 2011 MLstate

This file is part of OPA.

OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.

OPA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.

You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)

#<Debugvar:DEBUG_XML>

module List = BaseList

(* -- *)

let debug fmt =
  #<If> Printf.eprintf ("[Xml]"^^fmt)
  #<Else> Printf.ifprintf stdout fmt
  #<End>


(* FIXME: unifier avec Qml *)
type value =
  | Value of string
(* FIXME: remettre ??? | Func of string * value list *)
    (* string * string list (* parameters *) *)
;;

type parameters = value StringMap.t (* name *) (* FIXME: stringmap (* ns *) *)
;;
type nid = int
;;
type node =
    { nns : string option
    ; nname : string
    ; npars : parameters
    ; ncontent : content list
    ; nparent : int
    }
and content =
  | Text of string
  | Node of nid
;;

type xml =
    { header : (string * value) list (* parameters *)
    ; count : int
    ; main : int list
    ; nodes : node IntMap.t (* nidmap *) }
;;

let empty_xml =
  { header = []
  ; count = 0
  ; main = []
  ; nodes = IntMap.empty
  }
;;

let add_node node elt = { node with ncontent = (elt :: node.ncontent) }

let new_node n o =
  { nns = None
  ; nname = n
  ; npars = StringMap.from_list o
  ; ncontent = []
  ; nparent = -1
  }

let rewrite l =
  let rec aux ok stack xml = function
    | `one ((n, _) as t) :: tl -> aux ok stack xml (`start t :: `stop n :: tl)
    | `start (n, o) :: tl ->
        debug "start: %s" n;
        let nid = xml.count
        and node = new_node n o in
        let stack, is_main = match stack with
        | (snid, snode) :: stl ->
            (nid, { node with nparent = snid }) ::
              (snid, add_node snode (Node nid)) :: stl, false
        | _ ->
            [nid, node], true
        in
        let xml = if is_main then { xml with main = nid :: xml.main } else xml in
        aux ok stack { xml with count = succ nid } tl
    | `stop n :: tl ->
        debug "stop: %s" n;
        begin match stack with
        | (nid, node) :: stl ->
            if node.nname = n then
              let node = { node with ncontent = List.rev node.ncontent } in
              aux ok stl { xml with nodes = IntMap.add nid node xml.nodes } tl
            else (
              debug "error in rewrite: closing tag %s which is not last open tag" n;
              aux false stack xml tl
            )
        | _ ->
            debug "error in rewrite: closing tag %s which is not open" n;
            aux false stack xml tl
        end
    | `text t :: tl ->
        debug "text: %s" t;
        begin match stack with
        | (nid, node) :: stl ->
            let node = add_node node (Text t) in
            aux ok ((nid, node)::stl) xml tl
        | _ ->
            debug "error in rewrite: text '%s' outside of tag (skipped)" t;
            aux false stack xml tl
        end
    | `space :: tl ->
        let l = if stack=[] then tl else (`text " " :: tl) in
        aux ok stack xml l
    | _ ->
        if stack=[] then { xml with main = List.rev xml.main }, ok
        else
          let id = fst (List.hd stack) in
          let name = (snd (List.hd stack)).nname in
          debug "error in rewrite: tag <%d:%s> is never closed" id name;
          aux false stack xml [`stop name]
  in
  aux true [] empty_xml l

let print_options m =
  StringMap.fold (
    fun x (Value y) acc ->
      acc ^ Printf.sprintf " %s=\"%s\"" x (String.escaped y)
  ) m ""

let print_header m =
  List.fold_left (
    fun acc (x, Value y) ->
      acc ^ Printf.sprintf " %s=\"%s\"" x (String.escaped y)
  ) "" m

(** print options and apply a function to each element
-> utilisé par exemple pour remplacer
action: par javascript: dans les lients *)
let print_options_f f m =
  StringMap.fold (
    fun x (Value y) acc ->
      acc ^ Printf.sprintf " %s=\"%s\"" x (String.escaped (f x y))
  ) m ""

let fold f1 f2 init xml =
  let rec aux ~path acc nid =
    let path = nid :: path in
    let node = IntMap.find nid xml.nodes in
    let acc = f1 acc node.nname node.npars in
    List.fold_left (
      fun acc x -> match x with
      | Text t -> f2 acc path t
      | Node n -> aux ~path acc n
    ) acc node.ncontent
  in
  List.fold_left (aux ~path:[]) init xml.main


(* List.map ( *)
(* fun x -> match x with *)
(* | Text t -> f node.nname node.npars t *)
(* | n -> n *)
(* ) node.ncontent *)
let change_content f node =
  let rec aux acc_content acc_nodes = function
    | (Text t) :: tl ->
        let items, delete, insert = f node.nname node.npars t in
        let acc_nodes = insert @ acc_nodes in
        if delete then None, acc_nodes
        else aux (items @ acc_content) acc_nodes (* FIXME: check rev *) tl
    | n :: tl -> aux (n :: acc_content) acc_nodes tl
    | _ -> Some (List.rev acc_content), acc_nodes
  in aux [] [] node.ncontent

let delete_node ?(replace=[]) xml parent nid =
  match parent with
  | None -> { xml with main = List.remove_all nid xml.main }
  | Some p ->
      let parent_node = IntMap.find p xml.nodes in
      let parent_content = List.replace (Node nid) (List.map (fun x -> Node x) replace) parent_node.ncontent in
      { xml with nodes = IntMap.add p { parent_node with ncontent = parent_content } xml.nodes }

let insert_node parent (xml, nid_list) (n, o, content) =
  debug "insert_node" ;
  let nid = xml.count
  and node = new_node n o in
  let node =
    { node with
        nparent = (match parent with Some p -> p | _ -> -1)
        ; ncontent = content } in
  { xml with nodes = IntMap.add nid node xml.nodes ; count = succ xml.count },
  nid :: nid_list

(** map sur le texte des noeuds Xml *)
(* FIXME: rename *)
let map f xml =
  let rec aux parent xml nid =
    let node = IntMap.find nid xml.nodes in

    match change_content f node with
    | Some ncontent, _insert ->
        (* nouveau contenu de la node *)
        let xml =
          { xml with nodes =
              IntMap.add nid { node with ncontent = ncontent } xml.nodes }
        (* liste des nid à modifier *)
        and next = List.fold_left (
          fun acc x -> match x with
          | Node n -> n :: acc
          | _ -> acc
        ) [] node.ncontent
        in
        List.fold_left (aux (Some nid)) xml next
    | _, insert ->
        let xml, nid_list = List.fold_left (insert_node parent) (xml, []) insert in
        delete_node xml parent nid ~replace:nid_list
  in
  List.fold_left (aux None) xml xml.main

let print ?(header=false) ?(pretty=false) xml =
  let nl = if pretty then "\n" else "" in
  let rec aux b nid =
    let node = IntMap.find nid xml.nodes in
    let b = FBuffer.add b (Printf.sprintf "<%s%s>%s" node.nname (print_options node.npars) nl) in
    let b = List.fold_left (
      fun acc x -> match x with
      | Text t -> FBuffer.add acc t
      | Node n -> aux acc n
    ) b node.ncontent in
    FBuffer.add b (Printf.sprintf "</%s>%s" node.nname nl)
  in
  let b = FBuffer.make ~name:"Xml.print" 256 in
  let b =
    if header then
      FBuffer.add b (Printf.sprintf "<?xml%s ?>%s" (print_header xml.header) nl)
    else b in
  FBuffer.contents (List.fold_left aux b xml.main)

(** construit un stringmap: id -> nid pour un xml
retourne également un booléen FAUX si les ids sont correctes, VRAI si une id est redéfinie
*)
let build_ids ?(tag="id") xml =
  IntMap.fold (
    fun id node (acc, err) ->
      if StringMap.mem tag node.npars then
        let (Value value) = StringMap.find tag node.npars in
        let mem = StringMap.mem value acc in
        #<If> if mem then
              debug "Warning: id %s is defined several times" value #<End>;
        StringMap.add value id acc, mem or err
      else (acc, err)
  ) xml.nodes (StringMap.empty, false)

(** construit un stringmap: class -> nid list (classée par position décroissante) pour un xml *)
let build_classes ?(tag="class") xml =
  IntMap.fold (
    fun id node acc ->
      if StringMap.mem tag node.npars then
        let (Value value) = StringMap.find tag node.npars in
        let list = if StringMap.mem value acc then StringMap.find value acc else [] in
        StringMap.add value (id::list) acc
      else acc
  ) xml.nodes StringMap.empty

(** liste (id, tag)* des parents du noeud nid *)
let tag_path xml nid =
  let rec aux path id =
    if id = 0 then path
    else
      let node = IntMap.find id xml.nodes in
      aux ((node.nparent, node.nname)::path) node.nparent
  in
  aux [] nid
Something went wrong with that request. Please try again.