path: root/odf/odf.ml

module Xml = Ezxmlm
module T = Tools
module NS = Odf_ns

let u = UTF8.from_utf8string

type t

(** Map for storing all the attributes *)
module AttributesMap = Map.Make (struct
  type t = string * string
  let compare = Pervasives.compare
end)

let get_attr map key = begin
  try Some (AttributesMap.find key map) with
  Not_found -> None
end

let load_formula formula =
  let lineBuffer = Lexing.from_string formula in
  try
    Expression.Formula (
      Expression.Expression (
        Odf_ExpressionParser.value Odf_ExpressionLexer.read lineBuffer))
  with e ->
    print_endline formula;
    raise e


let load_content content = begin function
  | "float" -> Expression.Basic (
      ScTypes.Num (
        (Tools.Num.of_float_string content), Some (u @@ Tools.String.filter_float content)))
  | "date"  -> Expression.Basic (
      ScTypes.Date (
        Tools.Date.from_string content))
  | _ -> Expression.Basic (
      ScTypes.Str (
        UTF8.from_utf8string content))
end

(** Load the content from a cell *)
let load_cell sheet cell_num row_num changed (attrs, cell) = begin

  (* Load all the attributes from the xml element *)
  let add_attr map (key, value) = AttributesMap.add key value map in
  let attributes = List.fold_left add_attr AttributesMap.empty attrs in

  (* Check if the content is repeated *)
  let repetition = match get_attr attributes NS.number_columns_repeat_attr with
  | None -> 1
  | Some x -> int_of_string x

  (* cell width *)
  and cell_width = match get_attr attributes NS.number_columns_spanned_attr with
  | None -> 1
  | Some x -> int_of_string x in

  let vtype =
    try List.assoc NS.ovalue_type_attr attrs
    with Not_found -> "" in

  let formula = get_attr attributes NS.formula_attr
  and value   = get_attr attributes NS.value_attr in

  let expression, update = begin match formula, value with
  | Some x, _ -> load_formula x, true
  | _, Some x ->
      (load_content x vtype) , true
  | _ ->
    begin try
          Xml.member "p" cell
       |> Xml.data_to_string
       |> fun x -> (load_content x vtype, true)
    with Xml.Tag_not_found _ -> Expression.Undefined, false
    end
  end in

  if update then (
    for i = 1 to repetition do
      cell_num := !cell_num + cell_width;
      sheet := snd @@ Sheet.Raw.add (!cell_num, !row_num) (Expression.load_expr expression) !sheet
    done
  ) else (
    cell_num := !cell_num + (repetition * cell_width )
  );
  changed || update
end

let load_row sheet row_num (attrs, row) = begin

  let repetition =
    try int_of_string @@ List.assoc (NS.table, "number-rows-repeated") attrs
    with Not_found -> 1 in

  let cells = Xml.members_with_attr "table-cell" row in

  try
    for i = 1 to repetition do
      incr row_num;
      let cell_num = ref 0 in
      if not (List.fold_left (load_cell sheet cell_num row_num) false cells) then
        (* No changes on the whole row. Do not repeat, and break the loop *)
        raise Not_found
    done
  with Not_found -> row_num := !row_num + repetition - 1
end

let load_xml input = begin

  let sheet = ref Sheet.Raw.empty in
  let row_num = ref 0 in

  let xml =
      Xmlm.make_input ~enc:(Some `UTF_8) (`Channel input)
      |> Xml.from_input
      |> snd in
  let rows = Xml.member "document-content" (xml::[])
    |> Xml.member "body"
    |> Xml.member "spreadsheet"
    |> Xml.member "table"
    |> Xml.members_with_attr "table-row" in
  List.iter (fun x -> (load_row sheet row_num) x) rows;
  !sheet
end


let load file =
  let tmp_file = Filename.temp_file "content" ".xml" in
  Unix.unlink tmp_file;

  let zip = Zip.open_in file in
  let content = Zip.find_entry zip "content.xml" in
  Zip.copy_entry_to_file zip content tmp_file;

  let input = open_in_bin tmp_file in
  Tools.try_finally
    (fun () -> load_xml input)
    (fun () ->
      close_in input;
      Unix.unlink tmp_file;
      Zip.close_in zip
    )


let write_type ovalue_type cvalue_type attrs output value = begin
  let attrs =
    (NS.ovalue_type_attr, ovalue_type)::
    (NS.cvalue_type_attr, cvalue_type)::
    attrs in

  Xmlm.output output (`El_start (NS.table_cell_node, attrs));
    Xmlm.output output (`El_start (NS.text_node, []));
        Xmlm.output output (`Data value);
    Xmlm.output output `El_end;
  Xmlm.output output `El_end;
end

(* Writers for differents types *)
let write_num   = write_type "float"  "float"
let write_str   = write_type "string" "string"
let write_bool  = write_type "bool"   "bool"
let write_error = write_type "string" "error"
let write_date  = write_type "date"   "date"

let write_basic attrs output = begin function
  | ScTypes.Num (n,_)  ->
      let value = (string_of_float @@ Num.float_of_num n) in
      write_num ((NS.value_attr, value)::attrs) output value
  | ScTypes.Str s  -> write_str  attrs output (UTF8.to_utf8string s)
  | ScTypes.Bool b -> write_bool attrs output (string_of_bool b)
  | ScTypes.Date d ->
      let value = Tools.Date.to_string d in
      write_date ((NS.date_value_attr, value)::attrs) output value
end

let write_formula output attrs f = begin function
  | ScTypes.Result x -> write_basic attrs output x
  | ScTypes.Error exn -> write_str attrs output "#NAME?"
end

let print_ref buffer c =
  UTF8.Buffer.add_string buffer @@ u"[.";
  begin match c with
  | ScTypes.Cell c -> UTF8.Buffer.add_string buffer @@ Cell.to_string c;
  | ScTypes.Range (c1, c2) ->
    UTF8.Buffer.add_string buffer @@ Cell.to_string c1;
    UTF8.Buffer.add_string buffer @@ u":.";
    UTF8.Buffer.add_string buffer @@ Cell.to_string c2;
  end;
  UTF8.Buffer.add_string buffer @@ u"]"

let rec print_expr buffer = begin function
  | ScTypes.Value (ScTypes.Num (n, _))  ->
      UTF8.Buffer.add_string buffer @@ u(string_of_float @@ Num.float_of_num n)
  | ScTypes.Value (ScTypes.Str s)  ->
      UTF8.Printf.bprintf buffer "\"%s\"" (UTF8.to_utf8string s)
  | ScTypes.Value (ScTypes.Bool b) ->
       u(string_of_bool b)
    |> UTF8.Buffer.add_string buffer
  | ScTypes.Value (ScTypes.Date d) ->
        u(Tools.Date.to_string d)
    |> UTF8.Buffer.add_string buffer
  | ScTypes.Ref r -> print_ref buffer r
  | ScTypes.Expression x ->
      UTF8.Buffer.add_char buffer '(';
      print_expr buffer x;
      UTF8.Buffer.add_char buffer ')';
  | ScTypes.Call (ident, params) ->
      begin match (UTF8.to_utf8string ident) with
      | "+" | "*" | "-" | "/" | "^" | "="
      | "<>" | "<=" | ">=" | "<" | ">" -> begin match params with
        | v1::[] ->
          UTF8.Printf.bprintf buffer "%s%a"
          (UTF8.to_utf8string ident)
          print_expr v1
        | v1::v2::[] ->
          UTF8.Printf.bprintf buffer "%a%s%a"
          print_expr v1
            (UTF8.to_utf8string ident)
          print_expr v2
        | _ ->
          UTF8.Buffer.add_string buffer ident;
          Tools.List.printb ~sep:(u";") print_expr buffer params
        end
      | _ ->
          UTF8.Buffer.add_string buffer ident;
          Tools.List.printb ~sep:(u";") print_expr buffer params
      end
end

let write_cell output value = begin function
  | Expression.Undefined -> ()
  | Expression.Basic b -> write_basic [] output b
  | Expression.Formula (Expression.Expression f) ->
      let buffer = UTF8.Buffer.create 10 in
      print_expr buffer f;
      let formula = UTF8.Buffer.contents buffer
                 |> UTF8.to_utf8string in
      write_formula output [(NS.formula_attr, ("of:=" ^formula))] f value
  | Expression.Formula (Expression.Error (i, s)) ->
      write_error [(NS.formula_attr, ("of:" ^ (UTF8.to_utf8string s)))] output (UTF8.to_utf8string s)
end

(** Jump to the wanted position *)
let goto output (from_x, from_y) (to_x, to_y) :unit = begin

  (** Insert as many rows than required *)
  let insert_rows count = begin
    (* Close the previous openend rows *)
    Xmlm.output output `El_end;

    if (count > 1) then (
      Xmlm.output output (
        `El_start (
          NS.table_row_node, [(NS.table_row_repeat_attr, string_of_int (count-1))]));
        Xmlm.output output (`El_start (NS.table_cell_node, []));
        Xmlm.output output `El_end;
      Xmlm.output output `El_end;
    );
    Xmlm.output output (`El_start (NS.table_row_node, []));
    1
  end

  (** Insert as many cells as required *)
  and insert_cells count = begin
    Xmlm.output output (
      `El_start (
        NS.table_cell_node, [(NS.number_columns_repeat_attr, string_of_int count)]));
    Xmlm.output output `El_end;
  end in

  (* Insert empty rows or columns until the desired position *)
  let jump_row = to_y - from_y in
  let from_x' =
    if jump_row > 0 then
      insert_rows jump_row
    else
      from_x in
  let jump_cell = to_x - from_x' in
  if jump_cell > 0 then
    insert_cells jump_cell
end

(** Write the cell content and return the updated position *)
let f output cursor position (expr, value) = begin

  goto output cursor position;

  (* Write the value *)
  write_cell output value expr;

  (* Return the update position *)
  Tools.Tuple2.map1 ((+) 1)  position
end

let save sheet file = begin
  let tmp_file = Filename.temp_file "content" ".xml" in
  Unix.unlink tmp_file;
  let out_channel = open_out_bin tmp_file in
  let zip = Zip.open_out file in

  let manifest = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\
<manifest:manifest xmlns:manifest=\"urn:oasis:names:tc:opendocument:xmlns:manifest:1.0\" manifest:version=\"1.2\">\
<manifest:file-entry manifest:full-path=\"/\" manifest:version=\"1.2\" manifest:media-type=\"application/vnd.oasis.opendocument.spreadsheet\"/>\
<manifest:file-entry manifest:full-path=\"content.xml\" manifest:media-type=\"text/xml\"/>
</manifest:manifest>" in

  Tools.try_finally (fun () ->

    let output = Xmlm.make_output  (`Channel out_channel) in
    Xmlm.output output (`Dtd None);
    Xmlm.output output (`El_start (NS.document_content_node, NS.name_spaces()));
      Xmlm.output output (`El_start (NS.body_node, []));
        Xmlm.output output (`El_start (NS.spreadsheet_node, []));
          Xmlm.output output (`El_start (NS.table_node, []));

            Xmlm.output output (`El_start (NS.table_row_node, []));
            ignore (Sheet.Raw.fold (f output) (1,1) sheet);
            Xmlm.output output `El_end;

          Xmlm.output output `El_end;
        Xmlm.output output `El_end;
      Xmlm.output output `El_end;
    Xmlm.output output `El_end;

    close_out out_channel;
    Zip.copy_file_to_entry tmp_file zip "content.xml";
    Zip.add_entry manifest zip "META-INF/manifest.xml"
  ) (fun () ->
    Zip.close_out zip;
    Unix.unlink tmp_file
  )
end