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.number ( DataType.Num.of_num (Tools.Num.of_float_string content) )) | "date" -> Expression.Basic ( ScTypes.date ( DataType.Num.of_num (Tools.Num.of_float_string content) )) | _ -> Expression.Basic ( ScTypes.string ( 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: type a. 'b list -> Xmlm.output -> a ScTypes.types -> unit = fun attrs output types -> begin match types with | ScTypes.Str s -> write_str attrs output (UTF8.to_utf8string s) | ScTypes.Bool b -> write_bool attrs output (string_of_bool b) | ScTypes.Num (data_type, d) -> let n = DataType.Num.to_num d in begin match ScTypes.get_numeric_type data_type with | ScTypes.Number -> let value = (string_of_float @@ Num.float_of_num n) in write_num ((NS.value_attr, value)::attrs) output value | ScTypes.Date -> let value = Date.to_string n in write_date ((NS.date_value_attr, value)::attrs) output value end 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 : UTF8.Buffer.buffer -> ScTypes.expression -> unit = fun buffer -> begin function | 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.Num (data_type, d)) -> let n = DataType.Num.to_num d in begin match ScTypes.get_numeric_type data_type with | ScTypes.Number -> UTF8.Buffer.add_string buffer @@ u(string_of_float @@ Num.float_of_num n) | ScTypes.Date -> u(Date.to_string n) |> UTF8.Buffer.add_string buffer end | 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 = "\ \ \ " 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