let query_parameters db query =
let params = Hashtbl.create 13 in
let bad state = raise (Bad_query state) in
let add_param name colopt =
try
ignore (Hashtbl.find params name)
with
Not_found ->
Hashtbl.add params name colopt
in
let table_by_name s =
try table_by_name db s
with Not_found ->
let msg = Printf.sprintf "No table %s in schema" s in
bad (Query_invalid_against_schema msg)
in
let env_from_from =
let f acc t =
let (name,t) = match t with
`table s -> (s, table_by_name s)
| `tableas (s1,s2) ->
let t = table_by_name s1 in
(s2, t)
in
if List.exists (fun (s,_) -> s = name) acc then
let msg = Printf.sprintf
"No unique table name %s in from clause" name
in
bad (Query_incorrect msg)
else
(name,t) :: acc
in
List.fold_left f
in
let get_column env = function
`ref s ->
let l = List.fold_left
(fun acc (table,t) ->
match column_by_name_opt t s with
None -> acc
| Some c -> (table,c)::acc)
[]
env
in
(
match l with
[] ->
let msg = Printf.sprintf "Unbound column name %s" s in
bad (Query_invalid_against_schema msg)
| [(_,c)] -> c
| _ :: _ :: _ ->
let msg = Printf.sprintf
"Ambiguous column name %s; could belong to %s"
s (String.concat ", " (List.map fst l))
in
bad (Query_invalid_against_schema msg)
)
| `refdotref (s1,s2) ->
try
let t = List.assoc s1 env in
column_by_name t s2
with
Not_found ->
let msg = Printf.sprintf "Unbound column name %s.%s" s1 s2 in
bad (Query_invalid_against_schema msg)
in
let check_column env c = ignore (get_column env c) in
let rec in_query_exp env = function
`select s -> in_select env s
| `union (q1,q2) ->
(in_query_exp env q1) @ (in_query_exp env q2)
| `unionall (q1,q2) ->
(in_query_exp env q1) @ (in_query_exp env q2)
and in_select env (_mod,selection,from,where_opt,group_by_opt,having_opt) =
let env = env_from_from env from in
let return_type =
match selection with
`star -> bad (Query_incorrect "'*' not supported in selection")
| `list l ->
let f = function
`column c -> Some (get_column env c)
| _ -> None
in
List.map f l
in
(match where_opt with None -> () | Some w -> in_condition env w);
(match group_by_opt with None -> () | Some g -> in_group_by env g);
(match having_opt with None -> () | Some h -> in_condition env h);
return_type
and in_group_by env l = List.iter (check_column env) l
and in_condition env = function
`cand (c1, c2)
| `cor (c1, c2) -> in_condition env c1; in_condition env c2
| `cnot c -> in_condition env c
| `p p -> in_predicate env p
and in_predicate env = function
`comparisonexp (e1,_,e2) -> in_exp env e1; in_exp env e2
| `comparisonselect (e1,_,sel) ->
in_exp env e1; ignore (in_select env sel)
| `between (_,e1,e2,e3) ->
in_exp env e1; in_exp env e2; in_exp env e3
| `like (_,e1,a1,a2opt) ->
in_exp env e1;
in_atom env a1;
(match a2opt with None -> () | Some a -> in_atom env a)
| `iscolnull (_,col) -> check_column env col
| `in_select (_,e1,sel) ->
in_exp env e1; ignore (in_select env sel)
| `in_atom_list (_,e1,l) ->
in_exp env e1; List.iter (in_atom env) l
| `allorany (e1,_,_,sel) ->
in_exp env e1; ignore (in_select env sel)
| `exists sel -> ignore (in_select env sel)
and in_exp env = function
`binop (_,e1,e2) ->
in_exp env e1; in_exp env e2
| `uminus e -> in_exp env e
| `atom a -> in_atom env a
| `column c -> check_column env c
| `functioncall _ ->
()
and in_atom env = function
`parameter p -> in_parameter env p
| _ -> ()
and in_parameter env = function
`single s -> add_param s None
| `single_annotated (s,s2,s3) ->
(
try
let t = table_by_name s2 in
let col = column_by_name t s3 in
add_param s (Some col)
with
Not_found ->
let msg = Printf.sprintf "Unknown column %s.%s" s2 s3 in
bad (Query_invalid_against_schema msg)
)
| `couple _ ->
bad (Query_incorrect "Don't know what to do with couple parameters")
| `indicator _ ->
bad (Query_incorrect "Don't know what to do with indicator parameters")
in
let (qexp,ordlist) = query in
let return_type = in_query_exp [] qexp in
let params =
Hashtbl.fold
(fun name colopt acc -> (name,colopt)::acc)
params
[]
in
let params = List.sort
(fun (name1,_) (name2,_) -> Pervasives.compare name1 name2)
params
in
(return_type, params)