src/main.ml

   1 (**
   2   Main
   3 *)
   4
   5 open Prelude
   6 open ExtLib
   7
   8 module L = List
   9 module S = String
  10
  11 let common_prefix = function
  12 | [] -> 0
  13 | x::_ as l ->
  14   let rec loop i =
  15     if String.length x <= i then i
  16     else
  17       if List.for_all (fun s -> i < String.length s && s.[i] = x.[i]) l then
  18         loop (i+1)
  19       else
  20         i
  21   in
  22   loop 0
  23
  24 let parse_one_exn (sql,props) =
  25     if Sqlgg_config.debug1 () then  prerr_endline sql;
  26     let (schema,params,kind) = Parser.parse_stmt sql in
  27     (* fill inferred sql for VALUES or SET *)
  28     let (sql,params) = match kind with
  29     | Stmt.Insert (Some (kind,schema), _) ->
  30       let (pre,each,post) = match kind with
  31       | Stmt.Values -> "(", (fun _ -> ""), ")"
  32       | Stmt.Assign -> "", (fun name -> name ^" = "), ""
  33       in
  34       let module B = Buffer in
  35       let b = B.create 100 in
  36       B.add_string b sql;
  37       B.add_string b " ";
  38       B.add_string b pre;
  39       let params' = ref [] in
  40       let first = common_prefix & List.map (fun attr -> attr.RA.name) schema in
  41       schema >> List.iter (fun attr ->
  42         if !params' <> [] then B.add_string b ",";
  43         let attr_ref_prefix = each attr.RA.name in
  44         let attr_name = String.slice ~first attr.RA.name in
  45         let attr_ref = "@" ^ attr_name in
  46         let pos_start = B.length b + String.length attr_ref_prefix in
  47         let pos_end = pos_start + String.length attr_ref in
  48         let param = ((Some attr_name,(pos_start,pos_end)),attr.RA.domain) in
  49         B.add_string b attr_ref_prefix;
  50         B.add_string b attr_ref;
  51         params' := param :: !params'
  52       );
  53       B.add_string b post;
  54       (B.contents b, params @ (List.rev !params'))
  55     | _ -> (sql,params)
  56     in
  57     {Stmt.schema=schema; params=params; kind=kind; props=Props.set props "sql" sql}
  58
  59 let parse_one x =
  60   try
  61     Some (parse_one_exn x)
  62   with
  63   | Parser_utils.Error (exn,(line,cnum,tok,tail)) ->
  64     begin
  65      let extra = match exn with
  66      | RA.Schema.Error (_,msg) -> msg
  67      | exn -> Printexc.to_string exn
  68      in
  69      let sql = fst x in
  70      Error.log "==> %s" sql;
  71      if cnum = String.length sql && tok = "" then
  72        Error.log "Error: %s" extra
  73      else
  74        Error.log "Position %u:%u Tokens: %s%s\nError: %s" line cnum tok (String.slice ~last:32 tail) extra;
  75      None
  76     end
  77
  78 let parse_one (sql,props as x) =
  79   match Props.get props "noparse" with
  80   | Some _ -> Some { Stmt.schema=[]; params=[]; kind=Stmt.Other; props=Props.set props "sql" sql }
  81   | None -> parse_one x
  82
  83 let drop_while p e =
  84   while Option.map p (Enum.peek e) = Some true do
  85     Enum.junk e
  86   done
  87
  88 type token = [`Comment of string | `Token of string | `Char of char |
  89               `Space of string | `Prop of string * string | `Semicolon ]
  90
  91 let get_statements ch =
  92   let lexbuf = Lexing.from_channel ch in
  93   let tokens = Enum.from (fun () ->
  94     if lexbuf.Lexing.lex_eof_reached then raise Enum.No_more_elements else
  95     match Sql_lexer.ruleStatement lexbuf with
  96     | `Eof -> raise Enum.No_more_elements
  97     | #token as x -> x)
  98   in
  99   let extract () =
 100     let b = Buffer.create 1024 in
 101     let props = ref Props.empty in
 102     let answer () = Buffer.contents b, !props in
 103     let rec loop smth =
 104       match Enum.get tokens with
 105       | None -> if smth then Some (answer ()) else None
 106       | Some x ->
 107         match x with
 108         | `Comment s -> ignore s; loop smth (* do not include comments (option?) *)
 109         | `Char c -> Buffer.add_char b c; loop true
 110         | `Space _ when smth = false -> loop smth (* drop leading whitespaces *)
 111         | `Token s | `Space s -> Buffer.add_string b s; loop true
 112         | `Prop (n,v) -> props := Props.set !props n v; loop smth
 113         | `Semicolon -> Some (answer ())
 114     in
 115     loop false
 116   in
 117   let extract () = try extract () with e -> Error.log "lexer failed (%s)" (Printexc.to_string e); None in
 118   let rec next () =
 119     match extract () with
 120     | None -> raise Enum.No_more_elements
 121     | Some sql ->
 122       begin match parse_one sql with
 123       | None -> next ()
 124       | Some stmt ->
 125           if not (RA.Schema.is_unique stmt.Stmt.schema) then
 126             Error.log "Error: this SQL statement will produce rowset with duplicate column names:\n%s\n" (fst sql);
 127           stmt
 128       end
 129   in
 130   Enum.from next >> List.of_enum
 131
 132 let with_channel filename f =
 133   match catch open_in filename with
 134   | None -> Error.log "cannot open file : %s" filename; f None
 135   | Some ch -> Std.finally (fun () -> close_in_noerr ch) f (Some ch)
 136