dbfwork: 'to_number(x)' is treated as simply 'x'

[ocaml-dbf.git] / mlxbase.ml

(*
  See:
  http://www.clicketyclick.dk/databases/xbase/format/
  http://www.dbase.com/KnowledgeBase/int/db7_file_fmt.htm
*)

external identity_string : string -> string = "%identity"
;


type col_type =
 [ CT_Character | CT_Number | CT_Logical | CT_Date | CT_Memo | CT_Float
 | CT_Binary | CT_General | CT_Picture | CT_Currency | CT_Datetime
 | CT_Integer | CT_Varifield | CT_VariantX | CT_Timestamp | CT_Double
 | CT_Autoincrement | CT_NullFlags
 ]
;


type col_spec =
 { col_name : string
 ; col_type : col_type
 ; field_size : int
 ; field_decim : int
 }
;


type dbf_common =
 { c_record_len : int
 ; c_header_len : int
 ; c_colspecs : list col_spec
 ; c_codepage : string
 }
;

type xbase_hint = [ IgnoreDeletedFlag ]
;

type dbf_reader =
 { r_com : dbf_common
 ; r_version : int
 ; r_records : int
 ; r_ch : in_channel
 ; r_cpcvt : (string -> string)
 ; r_ignore_deleted_flag : bool
 }
;


value get_reader_codepage r = r.r_com.c_codepage
;


value reader_with_decoder dec r =
  { (r) with r_cpcvt = dec }
;


exception Bad_format of string;

value badformat fmt = Printf.ksprintf (fun s -> raise (Bad_format s)) fmt
;


value coltypemaps =
 [ ('C', CT_Character) ; ('N', CT_Number) ; ('L', CT_Logical)
 ; ('D', CT_Date) ; ('M', CT_Memo) ; ('F', CT_Float) ; ('B', CT_Binary)
 ; ('G', CT_General) ; ('P', CT_Picture) ; ('Y', CT_Currency)
 ; ('T', CT_Datetime) ; ('I', CT_Integer) ; ('V', CT_Varifield)
 ; ('X', CT_VariantX) ; ('@', CT_Timestamp) ; ('O', CT_Double)
 ; ('+', CT_Autoincrement); ('0', CT_NullFlags)
 ]
;



value coltype_of_char c =
 try
  List.assoc c coltypemaps
 with
 [ Not_found -> badformat "column type '\\x%02x' not supported" (Char.code c)
 ]
;


value rec list_snd_assoc el lst =
 match lst with
 [ [] -> raise Not_found
 | [(h1, h2) :: t] ->
     if h2 = el
     then
       h1
     else
       list_snd_assoc el t
 ]
;


value char_of_coltype ct =
 list_snd_assoc ct coltypemaps
 (* no exc handling. *)
;


value colspecs_of_reader d = d.r_com.c_colspecs
;

value codepage_of_reader d = d.r_com.c_codepage
;


value get_uint16 str ofs =
 (Char.code str.[ofs]) + ((Char.code str.[ofs+1]) lsl 8)
;


value get_uint8 str ofs =
 (Char.code str.[ofs])
;


value get_uint32 str ofs =
  let lo = get_uint16 str ofs
  and hi = get_uint16 str (ofs+2) in
  if hi >= 0x4000
  then failwith "get_uint32: current limitation, more than max_int"
  else lo + (hi lsl 16)
;



value string_of_asciiz a =
 try
  let z = String.index a '\x00'
  in
   String.sub a 0 z
 with
 [ Not_found -> a ]
;


value cpcodemaps =
  [ (0x01, "437")
  ; (0x02, "850")
  ; (0x03, "1252")
  ; (0x64, "852")
  ; (0x65, "865")
  ; (0x66, "866")
  ; (0x6A, "437G")
  ; (0xC8, "1250")
  ; (0xC9, "1251")
  ]
;


value cp_of_code co =
  try (List.assoc co cpcodemaps)
  with
  [ Not_found -> Printf.sprintf "language_driver_0x%02x" co
  ]
;


value code_of_cp cp =
  list_snd_assoc cp cpcodemaps
;


value read_hdr_of_ch decode hints ch =
 let hdr = String.make 0x20 '\x00' in
 let () = assert (0x20 = input ch hdr 0 0x20) in
 let version = get_uint8 hdr 0x00
 and headerlen = get_uint16 hdr 0x08
 and recordlen = get_uint16 hdr 0x0A
 and records = get_uint32 hdr 0x04
 and cpage = cp_of_code (get_uint8 hdr 0x1D)
 in
   let rec read_col_spec ch =
     let col = String.make 0x20 '\x00' in
     let readbytes = input ch col 0 0x20
     in
       if readbytes = 0
       then
         raise (Bad_format "colspec read=0")
       else
         if col.[0] = '\x0D'
         then
           []
         else
           if readbytes <> 0x20
           then
             badformat "expected colspec of 0x20 bytes, got %u bytes" readbytes
           else
             let colname = string_of_asciiz (String.sub col 0 0x0B)
             and coltype = coltype_of_char col.[0x0B]
             and fieldsize = get_uint8 col 0x10
             and decimals = get_uint8 col 0x11 in
             let colrec =
               { col_name = colname
               ; col_type = coltype
               ; field_size = fieldsize
               ; field_decim = decimals
               }
             in
               [colrec :: read_col_spec ch]
    in
    let cspecs = read_col_spec ch
    in
    do
     { seek_in ch headerlen
     ;
       { r_records = records
       ; r_com =
          { c_record_len = recordlen
          ; c_header_len = headerlen
          ; c_colspecs = cspecs
          ; c_codepage = cpage
          }
       ; r_version = version
       ; r_ch = ch
       ; r_cpcvt = decode
       ; r_ignore_deleted_flag = List.mem IgnoreDeletedFlag hints
       }
     }
;


value open_reader ?(decode=identity_string) ?(hints=[]) dbffname =
  let ch = open_in_bin dbffname
  in
  try
   read_hdr_of_ch decode hints ch
  with
  [ x -> do {close_in ch; raise x} ]
;


value close_reader d =
  close_in d.r_ch
;


value read_record d =
  let r = String.make d.r_com.c_record_len '\x00'
  and parse_record =
    let rec parse_record_inner r cs i =
      (* îñòàâøèåñÿ colspecs -- cs, â ñòðîêå r, ñî ñìåùåíèÿ i. *)
      match cs with
      [ [] -> []
      | [c :: cstl] ->
          let sz = c.field_size
          in
            [ (String.sub r i sz)
            :: parse_record_inner r cstl (i+sz)
            ]
      ]
    in
      fun r ->
        parse_record_inner r d.r_com.c_colspecs 1
  in
  let rec read_record_inner () =
    let read () =
      let rec loop ofs =
        let toread = d.r_com.c_record_len - ofs in
        match input d.r_ch r ofs toread with
        [ 0 -> ofs
        | n -> if n = toread then ofs + n else loop (ofs + n)
        ]
      in
      loop 0
    in
    match (read (), d.r_version) with
    [ (0, 2) -> badformat "No EOF mark"
    | (0, _) -> raise End_of_file
    | (n, _) when n = d.r_com.c_record_len ->
        if d.r_version = 2 && r.[0] = '\x1A' then raise End_of_file else
        match (d.r_ignore_deleted_flag, r.[0]) with
        [ (True,_) 
        | (False,' ') -> parse_record (d.r_cpcvt r)
        | (False,'*') -> read_record_inner ()
        | _ -> badformat "bad deleted_flag '%c'" r.[0]
        ]
    | (n, _) -> if r.[0] = '\x1A' then raise End_of_file else badformat "Expected EOF mark, got '%c'" r.[0]
    ]
  in
  read_record_inner ()
;


(*
value iterate_dbf filename fu =
  let d = open_reader dbf_testfname
  in
  let cs = d.r_com.c_colspecs
  in
  try do
    {
    while True do
      {
      let r = read_record d
      in
        fu cs r
      }
    }
 with
 [ End_of_file -> do { close_dbf d; () }
 | x -> do { close_dbf d; raise x } ]
;
*)



(**************** writing ***************)



type dbf_writer =
 { w_com : dbf_common
 ; w_records : mutable int
 ; w_ch : out_channel
 ; w_cpcvt : (string -> string)
 }
;


value set_uint8 str ofs v =
  let () = assert (v >= 0 && v <= 255) in
  str.[ofs] := Char.chr v
;

value set_uint16 str ofs v = do
  { assert (v >= 0 && v <= 0xFFFF)
  ; set_uint8 str ofs (v land 0xFF)
  ; set_uint8 str (ofs+1) (v lsr 8)
  }
;

value set_uint32 str ofs v = do
  { assert (v >= 0)
  ; set_uint16 str ofs (v land 0xFFFF)
  ; set_uint16 str (ofs+2) (v lsr 16)
  }
;



value string_of_header dw =
  let cp =
    let cptxt = dw.w_com.c_codepage in
    try code_of_cp cptxt
    with
    [ Not_found ->
        invalid_arg (Printf.sprintf "unknown codepage %S" cptxt)
    ]
  in
  let h = String.make 0x20 '\x00' in
  let set_uint8 = set_uint8 h
  and set_uint16 = set_uint16 h
  and set_uint32 = set_uint32 h
  and t = Unix.gmtime (Unix.time ()) in
  do
    { set_uint8  0  3
    ; set_uint8  1  (t.Unix.tm_year mod 100)
    ; set_uint8  2  (1 + t.Unix.tm_mon)
    ; set_uint8  3  t.Unix.tm_mday
    ; set_uint32 4  dw.w_records
    ; set_uint16 8  dw.w_com.c_header_len
    ; set_uint16 10 dw.w_com.c_record_len
    ; set_uint8  29 cp
    ; h
    }
;


value make_asciiz wid str =
  let len = String.length str in
  let () = assert (len <= wid - 1) in
  let r = String.make wid '\x00' in
  let () = String.blit str 0 r 0 len in
  r
;


value string_of_char = String.make 1
;

value str0 len = String.make len '\x00'
;

value string_of_uint8 i =
  let () = assert (i >= 0 && i <= 255) in
  string_of_char (Char.chr i)
;


value output_field_descr ch fd =
  let () = assert (fd.field_size <= 255)
  and () =
    if fd.col_type = CT_Number
    then assert (fd.field_decim >= 0 && fd.field_decim <= 15
              && (fd.field_decim = 0 || fd.field_decim < fd.field_size-1))
    else assert (fd.field_decim = 0)
  in
  let d =
     (let n = fd.col_name in
      if String.length n < 11
      then make_asciiz 11 n
      else failwith (Printf.sprintf
        "Field name must have length from 1 to 10 (%S)" n)
     )
   ^ (string_of_char (char_of_coltype fd.col_type))
   ^ (str0 4)
   ^ (string_of_uint8 fd.field_size)
   ^ (string_of_uint8 fd.field_decim)
   ^ (str0 2)
   ^ (string_of_uint8 0x01)  (* "work area id" *)
   ^ (str0 11)
   in
   let () = assert (0x20 = String.length d) in
   output_string ch d
;


value open_writer ?(encode=identity_string) filename colspecs codepage =
  let com =
    { c_record_len =
        List.fold_left
          ( + ) 1
          (List.map (fun cs -> cs.field_size) colspecs)
    ; c_header_len = 0x20 + (0x20 * (List.length colspecs)) + 1
    ; c_colspecs = colspecs
    ; c_codepage = codepage
    } in
  let ch = open_out_bin filename in
  let w = 
    { w_com = com
    ; w_records = 0
    ; w_ch = ch
    ; w_cpcvt = encode
    }
  in do
    { output_string ch (String.make 0x20 '\xFF')
    ; List.iter (output_field_descr ch) colspecs
    ; output_char ch '\x0D'
    ; flush ch
    ; w
    }
;


value rewrite_header dw =
  let ch = dw.w_ch in do
  { seek_out ch 0
  ; output_string ch (string_of_header dw)
  ; flush ch
  }
;


value close_writer dw =
 let ch = dw.w_ch in do
  { ()
  ; output_char ch '\x1A'
  ; rewrite_header dw
  ; flush ch
  ; close_out ch
  }
;


value write_record dw vals =
  let b = String.make dw.w_com.c_record_len '\x00' in
  let rec make_record ofs colspecs vals =
    match (colspecs, vals) with
    [ ([], []) -> ()
    | ([], _) | (_, []) -> assert False
    | ([cs :: cstail], [v :: valstail]) ->
        let fsz = cs.field_size in do
          { if fsz <> String.length v
            then do
              { print_string "field length must be equal to value length"
              }
            else ()
          ; let v' = v ^ (String.make (fsz - String.length v) ' ')
(*
          ; Printf.printf "field value = %S\n" v'
*)
          ; String.blit v' 0 b ofs fsz
          ; make_record (ofs + fsz) cstail valstail
          }
    ]
  in do
    { b.[0] := '\x20'
    ; make_record 1 dw.w_com.c_colspecs vals
; assert
      ( try do { let (_:int) = String.index b '\x00' in False } with [ Not_found -> True ]
      
      )
    ; output_string dw.w_ch (dw.w_cpcvt b)
    ; dw.w_records := dw.w_records + 1
    }
;

(***************** fix ******************)

open Unix
;
open Printf
;


value dbf_fix dbfname =
  let filelen = (stat dbfname).st_size in
  let r = open_reader
    ~decode:(fun _ -> failwith "achtung!  dbf_fix reads records!")
    dbfname in
  let h = r.r_com in
  let real_records = (filelen - h.c_header_len) / h.c_record_len in
  let last_ofs = h.c_header_len + real_records * h.c_record_len in
  let last_size = last_ofs+1 in

  let do_fix () = do
    { close_reader r
    ; let w = open_out_gen [ Open_wronly; Open_binary ] 0 dbfname
    ; let rec_count_bin = String.make 4 '\x00' in do
        { set_uint32 rec_count_bin 0 real_records
        ; seek_out w 4
        ; output_string w rec_count_bin
        }
    ; seek_out w last_ofs
    ; output_char w '\x1A'
    ; close_out w
    ; try
        truncate dbfname last_size
      with
      [ Invalid_argument (*arg when arg =*) "Unix.truncate not implemented"
          ->
            printf "%s: truncate not implemented, skipping.\n" dbfname
      ]
    }
  in

  if real_records <> r.r_records
  then do
    { printf "%s: records in header: %i, records in file: %i\n"
        dbfname r.r_records real_records
    ; do_fix ()
    }
  else
  let () = printf "%s: records' count ok.\n" dbfname in
  if last_size <> filelen
  then do
    { printf "%s: file length is %i, must be %i\n"
        dbfname filelen last_size
    ; do_fix ()
    }
  else do
    { printf "%s: file length ok.\n" dbfname
    ; seek_in r.r_ch last_ofs
    ; let c = input_char r.r_ch
    ; if c <> '\x1A'
      then do
        { printf "%s: file terminator is %C, must be %C\n" dbfname c '\x1A'
        ; do_fix ()
        }
      else
        let () = close_reader r
        in
          ()
    }
;