10 let is_alpha = function
15 let common_prefix = function
19 if String.length x
<= i
then i
21 if List.for_all
(fun s
-> i
< String.length s
&& s
.[i
] = x
.[i
]) l
then
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
30 let parse_one_exn (sql
,props
) =
31 if Sqlgg_config.debug1
() then prerr_endline 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 ^
" = "), ""
40 let module B
= Buffer
in
41 let b = B.create
100 in
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'
60 (B.contents
b, params @ (List.rev
!params'
))
63 {Stmt.schema
=schema
; params=params; kind
=kind
; props
=Props.set props
"sql" sql
}
65 let parse_one (sql
, props
as x
) =
67 Some
(parse_one_exn x
)
69 | Parser_utils.Error
(exn
,(line
,cnum
,tok
,tail
)) ->
71 let extra = match exn
with
72 | Sql.Schema.Error
(_
,msg
) -> msg
73 | exn
-> Printexc.to_string exn
75 Error.log
"==> %s" sql
;
76 if cnum
= String.length sql
&& tok
= "" then
77 Error.log
"Error: %s" extra
79 Error.log
"Position %u:%u Tokens: %s%s\nError: %s" line cnum tok
(String.slice ~last
:32 tail
) extra;
83 Error.log
"Failed %s: %s" (Option.default
"" @@ Props.get props
"name") sql
;
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
}
92 while Option.map p
(Enum.peek e
) = Some
true do
96 type token
= [`Comment
of string | `Token
of string | `Char
of char
|
97 `Space
of string | `Prop
of string * string | `Semicolon
]
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
108 let b = Buffer.create
1024 in
109 let props = ref Props.empty
in
110 let answer () = Buffer.contents
b, !props in
112 match Enum.get
tokens with
113 | None
-> if smth
then Some
(answer ()) else None
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 ())
125 let extract () = try extract () with e
-> Error.log
"lexer failed (%s)" (Printexc.to_string e
); None
in
127 match extract () with
128 | None
-> raise
Enum.No_more_elements
130 begin match parse_one sql
with
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
);
138 Enum.from
next |> List.of_enum
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
)