(* * <COPYRIGHT> * Copyright 2003 Gerd Stolpmann * * <GPL> * This file is part of WTimer. * * WTimer is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * WTimer is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with WDialog; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA * </> *) (* $Id: db_pg.ml 23 2015-01-14 16:24:21Z gerd $ * ---------------------------------------------------------------------- * *) (* Access PostgreSQL *) module Connection = struct module P = Postgresql (* abbr *) let sql_no_data = 100 (* UnixODBC constant, from /usr/include/sql.h *) type bind_data = (string * string * string) (* dbname, username, passwd *) type conn_handle = Unbound | Bound of bind_data | Connected of (P.connection * bind_data * float * bool) (* The float is the time when the last query was executed. A negative * number means that the alarm is inactive. * The bool means that there is a transaction. *) type connection = conn_handle ref open Printf let _exec (conn : P.connection) s = (* prerr_endline ("EXECUTE " ^ s); *) let r = conn # exec ~expect:[P.Command_ok; P.Tuples_ok] s in r # get_all_lst let _exec_nr conn s = ignore(_exec conn s) let _begin_transaction = ref (fun c -> _exec_nr c "set transaction isolation level read committed"; _exec_nr c "begin work"; (* Since PG-7.3, the "set" changes only apply to the current transaction *) _exec_nr c "set constraints all immediate"; _exec_nr c "set datestyle = iso" ) let _rollback_transaction = ref (fun c -> _exec_nr c "rollback") let _commit_transaction = ref (fun c -> _exec_nr c "commit") let _disconnect c = c # finish let _connect (db_name, db_user, db_passwd) = (* db_name is parsed as "<db>@<host>:port" *) let real_dbname, post_at = try let at_sign = String.index db_name '@' in (String.sub db_name 0 at_sign, String.sub db_name (at_sign+1) (String.length db_name - at_sign - 1) ) with | Not_found -> (db_name, "") in let host, port = if post_at = "" then ("","") else let ssym = Netsockaddr.socksymbol_of_string post_at in match ssym with | `Inet _ -> failwith "Database host must be given as name, not as address" | `Inet_byname(n,p) -> (n,string_of_int p) | `Unix path -> (path,"") in new P.connection ~host ~port ~dbname:real_dbname () let create () = ref Unbound let close_after_timeout c t = let now = Unix.time() in match !c with Connected(c',bd,last,trans) -> if last > 0.0 && now -. last > float t then ( (* timeout! *) c := Bound bd; if trans then !_rollback_transaction c'; _disconnect c'; ) | _ -> () let bind ~db_name ~user_name ~passwd c = match !c with Unbound -> c := Bound (db_name, user_name, passwd) | _ -> failwith "Db_pg.bind" let unbind c = match !c with Unbound -> () | Bound(_,_,_) -> c := Unbound | Connected (c',_,_,trans) -> c := Unbound; if trans then !_rollback_transaction c'; _disconnect c' let exec c s = match !c with Unbound -> failwith "Db_pg.exec" | Bound (db_name, db_user, db_passwd as bd) -> let c' = _connect (db_name, db_user, db_passwd) in c := Connected(c', bd, -1.0, true); !_begin_transaction c'; _exec c' s | Connected(c',bd,_,trans) -> c := Connected(c', bd, -1.0, true); if not trans then !_begin_transaction c'; _exec c' s let exec_nr conn s = ignore(exec conn s) let commit c = match !c with Connected(c',bd,_,trans) -> c := Connected(c', bd, Unix.time(),false); if trans then ( try !_commit_transaction c' with error -> c := Bound bd; _disconnect c'; raise error ) | _ -> assert false let rollback c = match !c with Connected(c',bd,_,trans) -> c := Connected(c', bd, Unix.time(),false); if trans then ( try !_rollback_transaction c' with error -> c := Bound bd; _disconnect c'; raise error ) | _ -> assert false let is_connected c = match !c with Connected _ -> true | _ -> false (* ----------------------- SPECIAL FUNCTIONS ----------------------- *) let have_on_delete_cascade = true let have_time_keyword = "time" let have_interval_keyword = "interval" let day_interval d = sprintf "interval '%d days'" d let quote_re = Netstring_str.regexp "[\\']" let quote s = Netstring_str.global_replace quote_re "\\\\\\0" s let bool_true = "true" let bool_false = "false" let is_bool_true = function "1" | "t" | "true" | "y" | "yes" -> true | _ -> false let is_bool_false = function "0" | "f" | "false" | "n" | "no" -> true | _ -> false let expr_next_serial_value table column = (* Return the SQL expression to increment the counter for [table] and * [column], and to return the new value. *) sprintf "nextval('%s_%s_seq')" table column let expr_last_serial_value table column = (* Return the SQL expression to return the counter for [table] and * [column] again *) sprintf "currval('%s_%s_seq')" table column let get_last_serial_value c table column = let l = exec c (sprintf "select %s" (expr_last_serial_value table column)) in match l with [[ r ]] -> int_of_string r | _ -> failwith "get_last_serial_value" end