]> matita.cs.unibo.it Git - helm.git/blob - helm/software/components/hmysql/hSql.ml
fixed check, if 0 constructors then no List.nth is allowed
[helm.git] / helm / software / components / hmysql / hSql.ml
1 (* Copyright (C) 2005, HELM Team.
2  * 
3  * This file is part of HELM, an Hypertextual, Electronic
4  * Library of Mathematics, developed at the Computer Science
5  * Department, University of Bologna, Italy.
6  * 
7  * HELM is free software; you can redistribute it and/or
8  * modify it under the terms of the GNU General Public License
9  * as published by the Free Software Foundation; either version 2
10  * of the License, or (at your option) any later version.
11  * 
12  * HELM is distributed in the hope that it will be useful,
13  * but WITHOUT ANY WARRANTY; without even the implied warranty of
14  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15  * GNU General Public License for more details.
16  *
17  * You should have received a copy of the GNU General Public License
18  * along with HELM; if not, write to the Free Software
19  * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
20  * MA  02111-1307, USA.
21  * 
22  * For details, see the HELM World-Wide-Web page,
23  * http://cs.unibo.it/helm/.
24  *)
25
26 type error_code =
27  | OK
28  | Table_exists_error
29  | Dup_keyname
30  | No_such_table
31  | No_such_index
32  | Bad_table_error
33  | GENERIC_ERROR of string
34
35 exception Error of string
36
37 (* the exceptions raised are from the Mysql module *)
38
39 type dbtype = User | Library | Legacy
40 type dbimplementation = Mysql of HMysql.dbd | Sqlite of HSqlite3.dbd | FakeMySql
41 type result = Mysql_rc of HMysql.result | Sqlite_rc of HSqlite3.result | Nothing
42
43   (* host port dbname user password type *)
44 type dbspec = (string * int option * string * string * string option * dbtype) list
45 type dbd = (dbtype * dbimplementation) list 
46
47 let debug = false;;
48 let debug_print s = if debug then prerr_endline (Lazy.force s) else ();;
49
50 let pp_dbtype = function
51   | User -> "User"
52   | Library -> "Library"
53   | Legacy -> "Legacy"
54 ;;
55
56 let mk_dbspec l = l;;
57
58 let quick_connect dbspec =
59   HExtlib.filter_map 
60     (fun (host, port, database, user, password, kind) -> 
61       if Pcre.pmatch ~pat:"^file://" host then
62         Some (kind, (Sqlite (HSqlite3.quick_connect (kind = Library)
63           ~host:(Pcre.replace ~pat:"^file://" host) 
64           ?port ~user ~database ?password ())))
65       else if Pcre.pmatch ~pat:"^mysql://" host then
66         Some (kind, (Mysql (HMysql.quick_connect 
67           ~host:(Pcre.replace ~pat:"^mysql://" host)
68           ?port ~user ~database ?password ())))
69       else 
70         None)
71     dbspec      
72 ;;
73
74 let mk f1 f2 = function 
75   | (Sqlite dbd) -> Sqlite_rc (f1 dbd) 
76   | (Mysql dbd) -> Mysql_rc (f2 dbd)
77   | FakeMySql -> assert false
78 ;;
79
80 let mk_u f1 f2 = function 
81   | (_, (Sqlite dbd)) -> f1 dbd 
82   | (_, (Mysql dbd)) -> f2 dbd
83   | (_, FakeMySql) -> assert false
84 ;;
85
86 let wrap f x =
87   try f x with 
88   | HMysql.Error s | HSqlite3.Error s -> raise (Error s)
89   | Not_found -> raise (Error "Not_found")
90 ;;
91
92 let disconnect dbd = 
93   wrap (List.iter (mk_u HSqlite3.disconnect HMysql.disconnect)) dbd
94 ;;
95
96 let exec (dbtype : dbtype) (dbd : dbd) (query : string) = 
97   try
98     debug_print (lazy ("EXEC: " ^ pp_dbtype dbtype ^ "|" ^ query));
99     let dbd = List.assoc dbtype dbd in
100     wrap (mk (HSqlite3.exec query) (HMysql.exec query)) dbd
101   with Not_found -> 
102     if dbtype = Legacy then Nothing else raise (Error "No ro or writable db")
103 ;;
104
105 let map result ~f = 
106   match result with
107   | Mysql_rc rc -> HMysql.map rc ~f
108   | Sqlite_rc rc -> HSqlite3.map rc ~f
109   | Nothing -> []
110 ;;
111
112 let iter result ~f = 
113   match result with
114   | Mysql_rc rc -> HMysql.iter rc ~f
115   | Sqlite_rc rc -> HSqlite3.iter rc ~f
116   | Nothing -> ()
117 ;;
118
119 let sqlite_err = function 
120  | HSqlite3.OK -> OK
121  | HSqlite3.Table_exists_error -> Table_exists_error
122  | HSqlite3.Dup_keyname -> Dup_keyname
123  | HSqlite3.No_such_table -> No_such_table
124  | HSqlite3.No_such_index -> No_such_index
125  | HSqlite3.Bad_table_error -> Bad_table_error
126  | HSqlite3.GENERIC_ERROR s -> GENERIC_ERROR s
127 ;;
128
129 let mysql_err = function 
130  | HMysql.OK -> OK
131  | HMysql.Table_exists_error -> Table_exists_error
132  | HMysql.Dup_keyname -> Dup_keyname
133  | HMysql.No_such_table -> No_such_table
134  | HMysql.No_such_index -> No_such_index
135  | HMysql.Bad_table_error -> Bad_table_error
136  | HMysql.GENERIC_ERROR s -> GENERIC_ERROR s
137 ;;
138
139 let errno dbtype dbd =
140   wrap 
141     (fun d -> match List.assoc dbtype d with 
142     | Mysql dbd -> mysql_err (HMysql.errno dbd)
143     | Sqlite dbd -> sqlite_err (HSqlite3.errno dbd)
144     | FakeMySql -> assert false)
145     dbd
146 ;;
147
148 let escape dbtype dbd s = 
149   try
150       match List.assoc dbtype dbd with
151       | Mysql _ | FakeMySql -> wrap HMysql.escape s
152       | Sqlite _ -> wrap HSqlite3.escape s
153   with Not_found -> 
154     if dbtype = Legacy then s else raise (Error "No ro or writable db")
155 ;;
156
157 let escape_string_for_like dbtype dbd = 
158   try
159       match List.assoc dbtype dbd with 
160       | Mysql _ | FakeMySql -> HMysql.escape_string_for_like
161       | Sqlite _ -> HSqlite3.escape_string_for_like
162   with Not_found -> 
163     if dbtype = Legacy then ("ESCAPE \"\\\"" : ('a,'b,'c,'a) format4) 
164     else raise (Error "No ro or writable db")
165 ;;
166
167 let isMysql dbtype dbd =
168   wrap 
169     (fun d -> match List.assoc dbtype d with Mysql _ -> true | _ -> false) 
170     dbd
171 ;;
172
173 let fake_db_for_mysql dbtype =
174   [dbtype, FakeMySql]  
175 ;;