(*
 * Xml-Light extension
 *
 * Copyright (C) 2004 CENA/ENAC, Pascal Brisset
 *
 * This file is part of paparazzi.
 *
 * paparazzi is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2, or (at your option)
 * any later version.
 *
 * paparazzi 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 General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with paparazzi; see the file COPYING.  If not, write to
 * the Free Software Foundation, 59 Temple Place - Suite 330,
 * Boston, MA 02111-1307, USA.
 *
 *)

open Printf

exception Error of string

let sep = Str.regexp "\\."

let child xml ?select c =
  let rec find = function
  Xml.Element (tag, _attributes, _children) as elt :: elts ->
    if tag = c then
      match select with
          None -> elt
        | Some p ->
          if p elt then elt else find elts
    else
      find elts
    | _ :: elts -> find elts
    | [] -> raise Not_found in


  let children = Xml.children xml in

  (* Let's try with a numeric index *)
  try (Array.of_list children).(int_of_string c) with
      Failure "int_of_string" -> (* Bad luck. Go through the children *)
        find children


let get xml path =
  let p = Str.split sep path in
  let rec iter xml = function
  [] -> failwith "ExtXml.get: empty path"
    | [x] -> ( try if Xml.tag xml <> x then raise Not_found else xml with _ -> raise Not_found )
    | x::xs -> iter (child xml x) xs in
  iter xml p

let get_attrib xml path attr =
  Xml.attrib (get xml path) attr

let sprint_fields = fun () l ->
  "<"^
    List.fold_right (fun (a, b) -> (^) (Printf.sprintf "%s=\"%s\" " a b)) l ">"

let attrib = fun x a ->
  try
    Xml.attrib x a
  with
      Xml.No_attribute _ ->
        raise (Error (Printf.sprintf "Error: Attribute '%s' expected in <%a>" a sprint_fields (Xml.attribs x)))

let tag_is = fun x v ->
  String.lowercase (Xml.tag x) = String.lowercase v



let attrib_or_default = fun x a default ->
  try Xml.attrib x a with _ -> default


(** Code patched from xml.ml from xml-light package: PC Data formatting removed *)
let tmp = Buffer.create 200
let buffer_attr = fun indent tab (n,v) ->
  if indent then
    Buffer.add_string tmp tab;
  Buffer.add_char tmp ' ';
  Buffer.add_string tmp n;
  Buffer.add_string tmp "=\"";
  let l = String.length v in
  for p = 0 to l-1 do
    match v.[p] with
      | '\\' -> Buffer.add_string tmp "\\\\"
      | '"' -> Buffer.add_string tmp "\\\""
    | c -> Buffer.add_char tmp c
        done;
  Buffer.add_char tmp '"';
        if indent then
          Buffer.add_char tmp '\n'

let buffer_pcdata = Buffer.add_string tmp
let my_to_string_fmt = fun tab_attribs x ->
  let rec loop ?(newl=false) tab = function
    | Xml.Element (tag,alist,[]) ->
      Buffer.add_string tmp tab;
      Buffer.add_char tmp '<';
      Buffer.add_string tmp tag;
      if tab_attribs then Buffer.add_char tmp '\n';
      List.iter (buffer_attr tab_attribs tab) alist;
      if tab_attribs then Buffer.add_string tmp tab;
      Buffer.add_string tmp "/>";
      if newl then Buffer.add_char tmp '\n';
    | Xml.Element (tag,alist,[Xml.PCData text]) ->
      Buffer.add_string tmp tab;
      Buffer.add_char tmp '<';
      Buffer.add_string tmp tag;
      List.iter (buffer_attr tab_attribs tab) alist;
      Buffer.add_string tmp ">";
      buffer_pcdata text;
      Buffer.add_string tmp "</";
      Buffer.add_string tmp tag;
      Buffer.add_char tmp '>';
      if newl then Buffer.add_char tmp '\n';
    | Xml.Element (tag,alist,l) ->
      Buffer.add_string tmp tab;
      Buffer.add_char tmp '<';
      Buffer.add_string tmp tag;
      List.iter (buffer_attr tab_attribs tab) alist;
      Buffer.add_string tmp ">\n";
      List.iter (loop ~newl:true (tab^"  ")) l;
      Buffer.add_string tmp tab;
      Buffer.add_string tmp "</";
      Buffer.add_string tmp tag;
      Buffer.add_char tmp '>';
      if newl then Buffer.add_char tmp '\n';
    | Xml.PCData text ->
      buffer_pcdata text;
      if newl then Buffer.add_char tmp '\n';
  in
  Buffer.reset tmp;
  loop "" x;
  let s = Buffer.contents tmp in
  Buffer.reset tmp;
  s



let to_string_fmt = fun ?(tab_attribs = false) xml ->
  let l = String.lowercase in
  let rec lower = function
  Xml.PCData _ as x -> x
    | Xml.Element (t, ats, cs) ->
      Xml.Element(l t,
                  List.map (fun (a,v) -> (l a, v)) ats,
                  List.map lower cs) in
  my_to_string_fmt tab_attribs (lower xml)


let subst_attrib = fun attrib value xml ->
  let u = String.uppercase in
  let uattrib = u attrib in
  match xml with
      Xml.Element (tag, attrs, children) ->
        let rec loop = function
        [] -> [(attrib, value)]
          | (a,_v) as c::ats ->
            if u a = uattrib then loop ats else c::loop ats in
        Xml.Element (tag,
                     loop attrs,
                     children)
    | Xml.PCData _ -> xml


let subst_child = fun ?(select= fun _ -> true) t x xml ->
  match xml with
      Xml.Element (tag, attrs, children) ->
        let found = ref false in
        let new_children =
          List.map
            (fun xml -> if tag_is xml t && select xml then (found := true; x) else xml)
            children in
        if !found then
          Xml.Element (tag, attrs, new_children)
        else
          raise Not_found
    | Xml.PCData _ -> xml


let subst_or_add_child = fun t x xml ->
  try subst_child t x xml with Not_found ->
    match xml with
        Xml.Element (tag, attrs, children) ->
          Xml.Element (tag, attrs, x::children)
      |  Xml.PCData _ -> xml


let remove_child = fun ?(select= fun _ -> true) t xml ->
  match xml with
      Xml.Element (tag, attrs, children) ->
        Xml.Element (tag,
                     attrs,
                     List.fold_right (fun xml rest -> if tag_is xml t && select xml then rest else xml::rest) children [])
    | Xml.PCData _ -> xml


let float_attrib = fun xml a ->
  let v = attrib xml a in
  try
    float_of_string v
  with
      _ -> failwith (Printf.sprintf "Error: float expected in '%s'" v)

let int_attrib = fun xml a ->
  let v = attrib xml a in
  try
    int_of_string v
  with
      _ -> failwith (Printf.sprintf "Error: integer expected in '%s'" v)


(* When an .xml is coming through http, the dtd is not available. We disable
   the DTD proving feature in this case. FIXME: We should use the resolve
   feature *)
let my_xml_parse_file =
  let parser = XmlParser.make () in
  XmlParser.prove parser false;
  fun f ->
    XmlParser.parse parser (XmlParser.SFile f)


let parse_file = fun ?(noprovedtd = false) file ->
  try
    (if noprovedtd then my_xml_parse_file else Xml.parse_file) file
  with
      Xml.Error e -> failwith (sprintf "%s: %s" file (Xml.error e))
    | Xml.File_not_found f -> failwith (sprintf "File not found: %s" f)
    | Dtd.Prove_error e -> failwith (sprintf "%s: %s" file (Dtd.prove_error e))
    | Dtd.Check_error e -> failwith (sprintf "%s: %s" file (Dtd.check_error e))
    | Dtd.Parse_error e -> failwith (sprintf "%s: %s" file (Dtd.parse_error e))



let digest = fun xml ->
  Digest.string (Xml.to_string xml)

let predefined_general_entities =
  [ Str.regexp "&amp;", "&";
    Str.regexp "&quot;", "\"" ]

let display_entities = fun s ->
  List.fold_right
    (fun (regexp, displayed_as) r -> Str.global_replace regexp displayed_as r)
    predefined_general_entities
    s

module Gconf = struct
  let get_value = fun xml name ->
    let e = child ~select:(fun x -> Xml.attrib x "name" = name) xml "entry" in
    Xml.attrib e "value"

  let entry = fun application name value ->
    Xml.Element ("entry", ["name", name;
                           "value", value;
                           "application", application],
                 [])

  let add_entry = fun xml appli name value ->
    let entry = entry appli name value in
    let select = fun x -> Xml.attrib x "name" = name in
    let xml = remove_child ~select "entry" xml in
    Xml.Element (Xml.tag xml, Xml.attribs xml, entry::Xml.children xml)
end
