src/main.ml

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